Funktion optimieren

[Pseudemys Nelsoni]

Moin,

ich habe folgende funktion(eine von vielen) geschrieben:

Delphi-Quellcode:

function AddTok(const S, T: string; const C: Char; CS: Boolean = False): string;
var
  SLen, SIdx, ResIdx, TokStart, TokLen: Integer;
  TokExists: Boolean;
  CurrentTok: string;
begin
  if T <> '' then
  begin
    SLen := Length(S);
    SetLength(Result, SLen+Length(T)+1);
    ResIdx := 0;
    TokExists := False;
    TokStart := 0;
    TokLen := 0;
    for SIdx := 1 to SLen do
    begin
      if (S[SIdx] <> C) or ((ResIdx > 0) and (Result[ResIdx] <> C)) then
      begin
        Inc(ResIdx);
        Result[ResIdx] := S[SIdx];
      end;
      if S[SIdx] <> C then
      begin
        if TokStart = 0 then
          TokStart := SIdx;
        Inc(TokLen);
      end;
      if ((S[SIdx] = C) or (SIdx = SLen)) and (TokStart > 0) then
      begin
        CurrentTok := Copy(S, TokStart, TokLen);
        if not TokExists then
        TokExists := ((CS) and (lstrcmp(PChar(CurrentTok), PChar(T)) = 0)) or
          ((not CS) and (lstrcmpi(PChar(CurrentTok), PChar(T)) = 0));
        TokStart := 0;
        TokLen := 0;
      end;
    end;
    if (ResIdx > 0) and (Result[ResIdx] = C) then
      SetLength(Result, ResIdx-1)
    else SetLength(Result, ResIdx);
    if not TokExists then
      if Result <> '' then
        Result := Result + C + T
      else Result := Result + T;
  end else
    Result := S;
end;

Sie tut nichts anderes, also ein neues wort(T) ans Ende anzufügen, SOFERN es nicht bereits vorkommt (S). Die Wörter selbst sind durch einen Seperator getrennt (C). CS gibt an ob ein vorhandenes Wort mit dem hinzuzufügenden case sensitive sein muss. Am Ende muss der String (im Erfolgsfall) auch sauber wieder zurückgegeben werden, d.h wenn S am Anfang so aussieht:

Zitat:

....Wort1..Wort2.........Wort3....Wort4..

und ich "Wort5" anfügen will, muss es am Ende so aussehen:

Zitat:

Wort1.Wort2.Wort3.Wort4.Wort5

Die Funktion (s.o) funktioniert.... nur kann man sie noch schneller machen?

[Dani]

Delphi-Quellcode:

function AppendStringIfUnique(StrToChange: String; StrToAppend: String;
  SepChar: Char): String;
begin
 Result := StrToChange;
 StrToAppend := StrToAppend + SepChar;
 If pos(SepChar + StrToAppend, StrToChange) = 0 then
  begin
   If Length(Result) = 0 then Result := SepChar;
   Result := Result + StrToAppend;
  end;
end;

ist auf meinem Rechner ca. um den Faktor 10 schneller, hat aber den Nachteil, dass der Zielstring mit einem Seperator beginnen muss. Falls das nichts ist, habe ich hier noch einen Nachbau deiner Funktion, der zwar mehr Speicher verbraucht, aber um ca. 20% schneller ist (trotzdem noch sehr langsam).

Delphi-Quellcode:

function AppendStringIfUnique(StrToChange: String; StrToAppend: String;
 SepChar: Char; WatchCase: Boolean = false): String;
var iNextSepIdx: Integer;
    sWord: String;
    sSrcStr, sDestStr: String;
    iSrcStrLength, iDestStrLength: Integer;
begin
 Result := StrToChange;
 If (Length(StrToChange)=0) or (Length(StrToAppend)=0) then
  begin
   Result := StrToAppend;
  end
   else begin
    If (not WatchCase) then
     begin
      //Speicher opfern, dafür den Vergleich bei Nichtbeachtung von
      //Groß/Kleinschreibung beschleunigen
      sSrcStr := AnsiLowercase(StrToChange);
      sDestStr := AnsiLowercase(StrToAppend);
     end
      else begin
       sSrcStr := StrToChange;
       sDestStr := StrToAppend;
      end;

    iSrcStrLength := Length(sSrcStr);
    iDestStrLength := Length(sDestStr);

    iNextSepIdx := 1;
    SetLength(sWord, 0);
    //Prüfen, ob das Wort schon enthalten ist, wenn ja die Funktion beenden

    while (iNextSepIdx + iDestStrLength -1 <= iSrcStrLength) do
     begin
     //Nächstes Wort besorgen und prüfen
      while (sSrcStr[iNextSepIdx] <> SepChar)
       and (iNextSepIdx < iSrcStrLength) do inc(iNextSepIdx);
      inc(iNextSepIdx);
      sWord := copy(sSrcStr, iNextSepIdx, iDestStrLength);
      If (sWord = sDestStr) then exit;
     end;

    //Wenn wir hier ankommen ist das Wort nicht im Quellstring enthalten
    Result := Result + SepChar + StrToAppend;
   end;
end;

[edit="Dani"]Delphi-Tags gesetzt[/edit]

[BrunoT]

Hi Pseudemys Nelsoni,

ich habe das mal mit Stringlist versucht.

Delphi-Quellcode:

function AddTok(const S, T: string; const C: Char; CS: Boolean = False): string;
var
  l: Tstringlist;
begin
  l := Tstringlist.Create;
  l.CaseSensitive := CS;
  l.Delimiter := c;
  l.DelimitedText := S;
  if l.IndexOf(T) < 0 then  //habe ich heute neu dazu gelernt 
    l.Add(T);
  result := l.DelimitedText;
   l.Free;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  memo1.Text := AddTok('wort1;wort2;wort3;wort4', 'wort5', ';', True);
end;

eventuell muss man ja die Stringlist nicht immer neu erzeugen.

mfg

BtunoT

[alzaimar]

Zitat von Dani:

[delphi]
... hat aber den Nachteil, dass der Zielstring mit einem Seperator beginnen muss....

Und? Häng' doch einfach den Separator temporär an die StrToAppend?

Alternativ kann man auch von Separator zu Separator hopsen und immer ab dieser Pos [+1] schauen, ob der StrToAppend vorkommt. Mit einem KMP verknüpft ist das denn auch fix genug, denke ich.

[Dani]

Selbst wenn man nur mit einer Instanz von TStringlist arbeitet, ist das der langsamste Ansatz. DelimitedText wird bei jedem Lesezugriff dynamisch aus TStringlist.Lines erzeugt und bei jedem Schreibzugriff wird TStringlist.Lines neu aufgebaut. Pseudemys Nelsonis Quellcode braucht für 10000 Test-Durchläufe ca. 34 Sekunden, der TStringlist Ansatz rechnet jetzt seit ca. 4 5 6 Minuten

[BrunoT]

Hätte nicht gedacht, dass das so viel langsamer ist.

mfg

BrunoT

[SirThornberry]

So ich hab auch noch bischen rumprobiert

AppendStringIfUnique = 422 ms
AddTok = 578 ms
AddIt2(von mir) 219 ms
AddIt3(von mir) 266 ms

[Edit]
Fehler in Funktion wurde behoben und Zeiten korrigiert
AddIt2 entfernt überflüssige Trennzeischen nicht
AddIt3 entfernt überflüssige Trennzeischen
[/Edit]
Allerdings weiß ich nicht ganz ob unter irgendwelchen Umständen meine Funktion fehlerhaft zurückgibt, wäre also nicht schlecht wenn mal jemand bischen testen könnte.

Delphi-Quellcode:

function AddIt2(const S, T: string; const C: Char; CS: Boolean = False): String;
  function IsSame(Str1: PChar; Str2: PChar; ALen: Integer): Boolean;
  var LPos: Integer;
  begin
    result := True;
    LPos := 0;
    while result and (LPos < ALen) do
    begin
      if Str1^ <> Str2^ then
        result := False;
      inc(Str1);
      inc(Str2);
      inc(LPos);
    end;
  end;
var LPos1, LPos2, LSourceLen, LTLen: Integer;
    LFound: Boolean;
    LS, LT: String;
    LSP, LTP: PString;
begin
  LSourceLen := Length(S);
  if Length(S) = 0 then
    result := T
  else begin
    if CS then
    begin
      LSP := @S;
      LTP := @T;
    end else begin
      LS := AnsiLowerCase(S);
      LT := AnsiLowerCase(T);
      LSP := @LS;
      LTP := @LT;
    end;
    LFound := False;
    LTLen := Length(T);
    LPos1 := 1;
    LPos2 := 1;
    while (LPos2 <= LSourceLen) and not(LFound) do
    begin
      if (LSP^[LPos2] = C) then
      begin
        LFound := (LPos2 - LPos1 = LTLen) and IsSame(@LSP^[LPos1], PChar(LTP^), LPos2 - LPos1);
        LPos1 := LPos2 + 1;
      end else if (LPos2 = LSourceLen) then
      begin
        LFound := (LPos2 - LPos1 + 1 = LTLen) and IsSame(@LSP^[LPos1], PChar(LTP^), LPos2 - LPos1 + 1);
        LPos1 := LPos2 + 1;
      end;
      inc(LPos2);
    end;

    if LFound then
      result := S
    else
    begin
      if S[LSourceLen] = C then
        result := S + T
      else
        result := S + C + T;
    end;
  end;
end;

Delphi-Quellcode:

function AddIt3(const S, T: string; const C: Char; CS: Boolean = False): String;
  function IsSame(Str1: PChar; Str2: PChar; ALen: Integer): Boolean;
  var LPos: Integer;
  begin
    result := True;
    LPos := 0;
    while result and (LPos < ALen) do
    begin
      if Str1^ <> Str2^ then
        result := False;
      inc(Str1);
      inc(Str2);
      inc(LPos);
    end;
  end;
var LPos1, LPos2, LSourceLen, LTLen: Integer;
    LFound: Boolean;
    LS, LT: String;
    LSP, LTP: PString;
begin
  LSourceLen := Length(S);
  if LSourceLen = 0 then
    result := T
  else begin
    if CS then
    begin
      LSP := @S;
      LTP := @T;
    end else begin
      LS := AnsiLowerCase(S);
      LT := AnsiLowerCase(T);
      LSP := @LS;
      LTP := @LT;
    end;
    LFound := False;
    LTLen := Length(T);
    LPos1 := 1;
    LPos2 := 1;
    while (LPos2 <= LSourceLen) and not(LFound) do
    begin
      if (LSP^[LPos2] = C) then
      begin
        LFound := (LPos2 - LPos1 = LTLen) and IsSame(@LSP^[LPos1], PChar(LTP^), LPos2 - LPos1);
        LPos1 := LPos2 + 1;
      end else if (LPos2 = LSourceLen) then
      begin
        LFound := (LPos2 - LPos1 + 1 = LTLen) and IsSame(@LSP^[LPos1], PChar(LTP^), LPos2 - LPos1 + 1);
        LPos1 := LPos2 + 1;
      end;
      inc(LPos2);
    end;

    if LFound then
      result := S
    else
    begin
      if S[LSourceLen] = C then
        result := S + T
      else
        result := S + C + T;
    end;

    //überflissige Zeischen rauskicken
    LPos2 := 1;
    LSourceLen := Length(result);
    for LPos1 := 1 to LSourceLen do
    begin
      if (result[LPos1] <> C) or (LPos1 <= 1) or (result[LPos1 - 1] <> C) then
      begin
        result[LPos2] := result[LPos1];
        inc(LPos2);
      end;
    end;
    if result[LPos2 - 1] = C then
      dec(LPos2);
    SetLength(result, LPos2 - 1);
  end;
end;

@Dani: Die Funktion ist um den Faktor 10 Schneller? Ich kann mir nicht vorstellen das So große unterschiede auftreten das deine Funktion gleich 10 mal schneller ist. Außerdem hast du bei dieser Variante das Casesensitive vergessen. Wenn ich bei mir als Parameter das Casesensitive auf False setze komme ich dann auch nur noch auf 78 ms

@Pseudemys Nelsoni: Bist du dir sicher das du die Trennzeischen herausfiltern willst wenn ein Leerstring dazwischen ist? Schließlich ist ein Leerstring nicht unbedingt etwas ungültiges.

[Dani]

Zitat von Sir Thornberry:

@Dani: Die Funktion ist um den Faktor 10 Schneller? Ich kann mir nicht vorstellen das So große unterschiede auftreten das deine Funktion gleich 10 mal schneller ist. Außerdem hast du bei dieser Variante das Casesensitive vergessen. Wenn ich bei mir als Parameter das Casesensitive auf False setze komme ich dann auch nur noch auf 78 ms

Hm, das könnte an meinem ungenauen Messverfahren liegen.

Delphi-Quellcode:

procedure TForm1.Button3Click(Sender: TObject);
var strBase, s, output: String;
    Idx: Integer;
    TimeStart, TimeEnd, TimeDiff: TDateTime;
begin
 strBase := 'Hurra';
 output := '';
 TimeStart := now;
 for Idx := 0 to 10000 do
  begin
   s := strBase + IntToStr(Idx);
   output := AppendStringIfUnique(output, s, ';');
  end;
  TimeEnd := now;
  TimeDiff := TimeEnd - TimeStart;

  Label1.Caption := 'time: ' + FormatDateTime('ss:zzz', TimeDiff);
  Memo1.Text := output;
end;

Pseudemys Nelsonis Code braucht auf meinem System (Athlon XP 2800+) dafür ca. 34 Sekunden, meiner 3.

[SirThornberry]

bei deinem Beispiel ist output aber auch leer so das die funktion so gut wie nix macht, in aller regel wird die funktion wohl nicht mit leerstrings aufgerufen. Aber so könnt ich mir den krassen Unterschied dann doch vorstellen.

[alzaimar]

Oh, da stimmt Einiges nicht;
1. Die Funktionen funktionieren alle nicht, weil sie auch für den Fall 'Wort111;Wort222' fälschlicherweise das 'Wort' finden. Das ist aber gar nicht in der Liste.

2. Ausserdem sind die AddK, Addit2 und Addit3 vom Aufwand O(n*m), wobei n die Länge der Liste und m die Länge des Wortes bezeichnet.

3. Abschließend ist das Testverfahren keins.

Hier ein Verfahren mit linearem Aufwand:

Delphi-Quellcode:

Function AddIfUnique (Const aList, aToken : String; aSep : Char) : String;
Var
  l,n : Integer;

  Function TokenExists : Boolean;
  Var
    i,j : Integer;

  Begin
    i := 0;
    j := 1;

    For i:=1 to l Do Begin
      If aList[i] = aSep Then // Separator gefunden? Vergleich initialisieren
        j := 1
      Else if (j>0) Then                  // Wir vergleichen das j.te Zeichen
        If aList[i] = aToken[j] Then      // das passt....
          If (j = n) Then                 // wurde das ganze Wort verglichen ?
            If (i = l) Or (aList[i+1] = aSep) Then Begin // und danach kommt
              Result := True;             // ein Separator? Dann sind wir
              Exit;                       // fertig.
              End
            Else                          // Ansonsten Vergleich bis zum
              j := 0                      // nächsten Separator ausschalten
          Else                            // Vergleich ok, also nächsten 
           Inc (j)                        // Buchstaben des Wortes anvisieren.
        Else                              // Vergleich bis zum nächsten
          j := 0;                         // Separator ausschalten
      End;
    Result := False
  End;

Begin
  l := Length (aList);
  n := Length (aToken);
  If TokenExists Then
    Result := aList
  Else If l = 0 Then  // Beim ersten Mal nur den Token liefern
    Result := aToken
  Else Begin
    Result := aList;  // sonst ';'Token anhängen
    SetLength (Result, l + n + 1);
    Result [l+1] := aSep;
    Move (aToken[1], Result [l+2], n);
    End
End;

Testverfahren:
Eine Wortliste bestehend aus 4000 Wörtern WortX (X=1...4000), durch ';' getrennt, wird erstellt.

a) 4000x wird "Wort[i]" eingefügt (schlägt fehl, da schon in der Liste)
b) 4000x wird "Wort[i]*" eingefügt. (klappt immer)

AddIfUnique a) : 661
AddIfUnique b) : 3645

AddIt3 a) : 6059
AddIt3 b) : 10485

Da ist bestimmt noch Optimierungspotential drin.