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. :wink:

mfg

BtunoT

[alzaimar]

Zitat:

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 :shock:

[BrunoT]

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

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:

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.

[SirThornberry]

@alzeimar: Irgendwie funktioniert es bei mir schon.
Bei folgendem Aufruf

Delphi-Quellcode:

showmessage(AddIt3('wort111;wort222', 'wort', ';', False));

bekomme ich
"wort111;wort222;wort"
ausgegeben weil wort eben noch nicht in der Zeischenfolge vorkam. Oder wie meintest du das?

[Dani]

Zitat:

Zitat von SirThornberry

bei deinem Beispiel ist output aber auch leer so das die funktion so gut wie nix macht

Beim ersten Aufruf von insgesamt 10001 ist output leer, beim Zweiten nicht mehr. :stupid:

Zitat:

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.

Sorry, aber hast du das irgendwie überprüft? Mein Ansatz mit Pos findet ein Wort NUR, wenn davor und dahinter ein Seperator steht.

Zitat:

3. Abschließend ist das Testverfahren keins.

Warum nicht? Kann man nicht annehmen, dass der zu bearbeitende String mit der Zeit größer wird?

[SirThornberry]

@Dani: habs bemerkt. Hab jetzt auch mal dein Testverfahren genutzt (was ja keins ist :wink: (frag mich nicht warum))
AppendStringIfUnique: 30.828 s
AddIt3: 22.766 s
AddIt2: 17.703 s

@alzaimar: Deine Funktion stimmt auch nicht. Erstens fehlt der Parameter/die Möglichkeit Casesensitive zu ignorieren und zweitens werden mehrere Trennzeischen hintereinander zugelassen.
Ansonsten ist die Funktion von dir mit 4.359 recht gut in der Zeit (so gut war meine bevor ich das Casesensitive eingebaut hatte und die doppelten Trennzeischen beseitigt hatte glaub ich nicht)

[alzaimar]

Hi Sir Thornberry, hi Dani...
Erstmal Tschuldigung für den Schnellschuss... Natürlich klappen die Routinen :oops: Probiert hatte ich es nicht, sondern in einem Anfall von Überarbeitung, Senilität und Altersschwachsinn (daher der Nick) zu schnell geschossen...

Zu Deiner Kritik:
Ich hatte geschrieben, das Gross/Kleinschreibung nicht ignoriert wird. Es ging mir nur um das Verfahren (linear).
Wieso sollen doppelte Trennzeichen (also leere Wörter in der Liste) weggeschmissen werden? Das kostet wirklich Zeit, aber ich habs mal eingebaut.

Dann hatte ich als Ordnung für deinen Algorithmus O(n*m) angegeben, was quark ist, wenn m die Länge des Wortes ist.
Dein Algo ist von der Ordnung O(n*m), wobei n die Länge der Liste und m ist die ANZAHL der Wörter und damit ist dein Algo nicht mehr soooo schlecht :zwinker:.

Zum Testverfahren von Dani: Das prüft nur den Fall, das ein Wort nicht gefunden wird, also ein worst-case. Wenn Du Quicksort mit einem Worst-Case testest, wird es langsamer als Bubblesort sein, insofern muss man schon aufpassen.

Ich habe mal ein Testprogramm geschrieben. Es erzeugt die schon erwähnte Wortliste, allerdings mit Random-Zeichen.
Ich habe auch eingebaut, das Wegschnippeln der ;; zu unterbinden. Leider kackt Thornies Algo dann ab, und ich hab keine Ahnung warum.

[Pseudemys Nelsoni]

Ganz vergessen hier zu posten :oops: :oops: :oops:

Danke für den Code, sieht ja hammer aus :cyclops: :cyclops: