String intelligent Kürzen

[BBoy]

Habe folgendes Problem. Ein String der eine Bezeichnung enthält muss auf 14 Zeichen gekürzt werden. Aber nicht einfach abgeschnitten, sondern eben Intelligent.

1. Aus der Bezeichnung sollen alle Sonderzeichen und Satzzeichen entfernt werden. nur a-z, A-Z und 0-9 sollen erhalten bleiben
2. Ist am Ende der Bezeichnung eine Zahl so muss diese erhalten bleiben
3. Aus der Bezeichnung sollen alle Leerzeichen entfernt werden.

Ich denke man müsste zuerst berechnen wie viele Worte der String hat, und dann von jedem Wort ein paar Anfangsbuchstaben nehmen. Wobei es gut wäre wenn vom ersten Wort mehr Buchstaben genommen werden als von den nächsten. Zudem muss jeder Name einmalig sein. Sollte ein Name doppelt sein, müsste dieser anders benannt werden.

Bsp:
aus "Kitho´s Serie Teil 3" sollte "KithoSeriTeil3" werden.
aus "Lorscher Geschichte 'Laurissa'" sollte "LorschGescLaur" werden
aus "Die Rheinblick Serie 12" sollte "DieRheinblSe12" werden.

Hat von euch jemand eine Idee wie ich das verwirklichen kann?
Danke!

[mkinzler]

-Zuerst die Überprüfung/ggf Trennung der Zahl
-Druchgehen Rest und Zeichen Löschen wenn nicht in [0..9][a..Z] oder leerzeichen
-Trenner nach Wörter
-Berechnung Buchstaben pro Wort: Restlänge ( 14 - Länge Zahl) / Anzahl Wörter
-Kopieren der Buchstaben
-Zahl wieder anhängen

[BBoy]

Vor allem mit diesem Punkt habe ich Probleme: -Berechnung Buchstaben pro Wort: Restlänge ( 14 - Länge Zahl) / Anzahl Wörter
Könnte mir das bitte jemand anhand dieses Beispiels erklären: aus "Lorscher Geschichte 'Laurissa'" sollte "LorschGescLaur" werden ?? Ein Codeschnipsel wäre super, da ich echt kein plan habe wie ich das machen soll.

[mkinzler]

In etwa so

Delphi-Quellcode:

function KuerzeDateiname( orig: string): string;
var
  sl: TStrings;
  s: string;
  i, j, g, ab: Integer;
begin
   //Ungueltige Zeichen entfernen
   s := '';
   for i := 1 to length( orig) do
   begin
       if orig[i] in [' ', 'a'..'z', 'A'..'Z'] then
           s := s + orig[i];
   end;
   //Nach Wörter trennen
   try
        sl := TStringList.Create;
        sl.Delimiter := ' ';
        sl.StrictDelimiter := True;
        sl.DelimitedText := s;
        ab := 14 DIV sl.Count; //Anzahl Buchstaben pro Wort
        for i := 0 to sl.Count -1 do
        begin
            g := min( Length( sl[i]), ab);
            for j := 1 to g do
            begin
                result := result + sl[i][j];
            end;
        end;
   finally
       sl.Free;
  end;
end;

Es besteht natürlich noch Überarbeitungsbedarf

[BBoy]

Danke.

Zitat:

Es besteht natürlich noch Überarbeitungsbedarf ( z.B. wenn ein Wort kürzer ist, als die zu kopierende Anzahl von Buchstaben)

Aber eben darin sehe ich ein Problem das ich nicht zu lösen weiß. Denn wenn wörter kürzer sind, soll es ja von den vorherigen dementsprechend mehr Buchstaben nehmen, aber auch das muss erst geprüft werden ob da genug vorhanden sind. Wenn nicht muss er vom nächsten Wort mehr Buchstaben nehmen aber auch da muss erst wieder geprüft werden ob es geht. Und genau das wir schwer finde ich..... oder gibt es da eine Möglichkeit das doch recht einfach zu lösen?

[mkinzler]

Ich habe den Code nochmal etwas überarbeitet/erweitert

-es werden nun Zahlen am Ende erhalten
-man kann die Ziellänge angeben
-Unterdeckungen ( weil Wort zu kurz) wird auf andere Wörter verteilt

Delphi-Quellcode:

function KuerzeDateiname( orig: string; nlen: Integer): string;
var
  sl: TStrings;
  s, s2: string;
  i, j, g, k, ab: Integer;
begin
   k := 0;
   //Zahl am Ende erkennen und abtrennen
   s2 := '';
   i := length( orig);
   while orig[i] in [ '0'..'9'] do
       dec(i);
   if i <  length( orig) then
   begin
       s2 := Copy( orig, i+1, length(orig) - i + 1 );
       Delete( orig, i+1, length( orig) - i + 1);
       nlen := nlen - Length(s2) - 1;
   end;
   //Ungueltige Zeichen entfernen
   s := '';
   Orig := Trim(Orig);
   for i := 1 to length( orig) do
   begin
       if orig[i] in [' ', 'a'..'z', 'A'..'Z'] then
           s := s + orig[i];
   end;
   //Nach Wörter trennen
   try
        sl := TStringList.Create;
        sl.Delimiter := ' ';
        sl.StrictDelimiter := True;
        sl.DelimitedText := s;
        ab := nlen DIV sl.Count; //Anzahl Buchstaben pro Wort
        for i := 0 to sl.Count -1 do
        begin
            g := min( Length( sl[i]), ab+k);
            if Length( sl[i]) < ab+k then
                k := ab+k - Length( sl[i])
            else
                k := 0;
            for j := 1 to g do
            begin
                result := result + sl[i][j];
            end;
        end;
        result := result + s2;
   finally
       sl.Free;
  end;
end;

[BBoy]

Hey echt cool was du da einfach so hervor zauberst, vielen Dank!! :thumb:

Allerdings stimmt das Ergebnis manchmal nicht. So macht er aus "Lorscher Geschichte Laurissa" folgendes "LorsGescLaur" also nur 12 Zeichen anstatt 14. Und bei "Geschichte der La" macht er nur "GescderLa" 9 Zeichen.
Woran liegt das? Leider verstehe ich deinen Code nicht genug um selbst den Grund zu finden.

[himitsu]

Er errechnet die Zeichen pro Wort und rundet dann ab, also muß da zwangsläufig ab und zu mal weniger rauskommen.

[mkinzler]

Ich habe ja geschrieben, dass der code nicht optimal ist, sondern nur einen möglichen Lösungsweg zeigen soll

Man könnte z.B. statt immer Abzurunden ( DIV ) Runden und dann am Ende den String auf die gewünschte Anzahl ( nlen abzgl. Länge Zahl) Trimmen, dann wre u.U die Anzahl der Buchstaben des letzten Worts weniger bzw. es würde dann komplett fehlen

[himitsu]

Delphi-Quellcode:

function KuerzeDateiname(S: String; Len: Integer): String;
var
  i, i2: Integer;
  SL: TStrings;
begin
  // ungültige Zeichen entfernen
  for i := Length(S) downto 1 do
    if not (S[i] in [' ', 'a'..'z', 'A'..'Z', '0'..'9']) then
      Delete(S, i, 1);
  // ungültige Zahlen entfernen
  while (i > 0) and (S[i] in ['0'..'9']) do
    Dec(i);
  for i := i downto 1 do
    if S[i] in ['0'..'9'] then
      Delete(S, i, 1);
  //
  SL := TStringList.Create;
  try
    // String aufsplitten
    SL.LineBreak := '';
    SL.Delimiter := ' ';
    SL.StrictDelimiter := True;
    SL.DelimitedText := S;
    // längstes Wort suchen
    i2 := 0;
    for i := SL.Count -1 downto 0 do
      i2 := Max(i2, Length(SL[i]));
    // Anzahl der zu entfernenden Zeichen
    Len := Length(SL.Text) - Len;
    // kurze Wörter (Einzelbuchstaben) entfernen
    i := SL.Count - 1;
    while (Len > 0) and (i >= 0) do begin
      if Length(SL[i]) = 1 then begin
        SL.Delete(i);
        Dec(Len);
      end;
      Dec(i);
    end;
    // Wörter kürzen
    i := -1;
    while (Len > 0) do begin
      if i < 0 then begin
        i := SL.Count - 1;
        Dec(i2);
      end;
      if Length(SL[i]) > i2 then begin
        SL[i] := Copy(SL[i], 1, i2);
        Dec(Len);
      end;
      Dec(i);
    end;
    // Text zusammensetzen und ausgeben
    Result := SL.Text;
  finally
    SL.Free;
  end;
end;

Bezüglich den doppelten Ergbnissen:
da müßte man jetzt bei

Delphi-Quellcode:

Result := SL.Text;

prüfen ob es das schon gibt, zu

Delphi-Quellcode:

// String aufsplitten

zurückspringen ('ne Repeat-Schleife mit Prüfung auf Doppeltes am Ende) und dann beim wiederholten Durchlauf einige der Löschungen überspringen und das dann solange bis es am Ende einzigartig ist.

Wie viele Buchstaben müssen denn im Durchschnitt gelöscht werden?
Jenachdem müßte man die Löschüberspringverwaltung erstellen (bis 32 = Integer, bis 64 = Int64, bis 256 = Set of Byte, mehr = Liste).

[BBoy]

Wie ihr das so auf die schnelle hin bekommt :)

Wie viele Buchstaben max. gelöscht werden sollen? Der String ist max. 128 Zeichen lang. Aber das kommt eigentlich nie vor. Schätze die max. länge des Strings auf etwa 50 oder 60.

Bei der Version von himitsu stimmt zwar immer die Länge aber es werden nicht alle Worte ausgegeben. So wird aus "Lorscher Geschichte Laurissa" leider nur "LorscherGeschi" das Wort "Laurissa" oder wenigstens ein teil davon kommt leider nicht. Aber das wäre wichtig. Da z.B. mehrere ähnliche Bezeichnungen vorkommen können:
"Lorscher Geschichte Laurissa"
"Lorscher Geschichte Mathilde"
usw...

Ich bin euch beiden echt Dankbar!! Ohne Euch wäre ich voll aufgeschmissen :oops:

Geht es nicht irgendwie das er in bestimmten Fällen halt 15 Zeichen zurück gibt und man dann wieder eins löscht (aber keine zahl am ende)?

[mkinzler]

Man könnte meine Version leicht anpassen, dass das letzte Wort komplett angehängt wird und dann auf nlen gekürzt wird

Delphi-Quellcode:

function KuerzeDateiname( orig: string; nlen: Integer): string;
var
  sl: TStrings;
  s, s2, res: string;
  i, j, g, k, ab: Integer;
begin
   k := 0;
   //Zahl am Ende erkennen und abtrennen
   s2 := '';
   i := length( orig);
   while orig[i] in [ '0'..'9'] do
       dec(i);
   if i < length( orig) then
   begin
       s2 := Copy( orig, i+1, length(orig) - i + 1 );
       Delete( orig, i+1, length( orig) - i + 1);
       nlen := nlen - Length(s2) - 1;
   end;
   //Ungueltige Zeichen entfernen
   s := '';
   Orig := Trim(Orig);
   for i := 1 to length( orig) do
   begin
       if orig[i] in [' ', 'a'..'z', 'A'..'Z'] then
           s := s + orig[i];
   end;
   //Nach Wörter trennen
   try
        sl := TStringList.Create;
        sl.Delimiter := ' ';
        sl.StrictDelimiter := True;
        sl.DelimitedText := s;
        ab := nlen DIV sl.Count; //Anzahl Buchstaben pro Wort
        for i := 0 to sl.Count -2 do
        begin
            g := min( Length( sl[i]), ab+k);
            if Length( sl[i]) < ab+k then
                k := ab+k - Length( sl[i])
            else
                k := 0;
            for j := 1 to g do
            begin
                res := res + sl[i][j];
            end;
        end;
        inc(i);
        res := res + sl[i];
        res := Copy( res, 1, nlen);
        result := res + s2;
   finally
       sl.Free;
  end;
end;

[himitsu]

Wenn man Code blind schreibt und nicht prüft :oops:
- waren eigentlich nur 2 Fehler ' ' wurde als ungültiges Zeichen mit gelöscht
- und beim Zahlenentfernen war ein NOT zuviel (sei froh, daß keine Zahl vorkam, sonst wären alle -buchstaben gelöscht wurden :lol:)
> hab's im Post #10 geändert

Delphi-Quellcode:

type TKueDatErlaubt = function(S: String): Boolean;
// type TKueDatErlaubt = function(S: String): Boolean of object;  // für Objektmethoden
// type TKueDatErlaubt = reference to function(S: String): Boolean;  // ab D2010 für Alles

function KuerzeDateiname(S: String; Len: Integer; Erlaubt: TKueDatErlaubt): String;
var
  i, i2, u: Integer;
  SL: TStrings;
  US: record
    case Integer of
      0: (i: Int64);
      1: (s: Set of 0..63);
  end;
begin
  // ungültige Zeichen entfernen
  for i := Length(S) downto 1 do
    if not (S[i] in [' ', 'a'..'z', 'A'..'Z', '0'..'9']) then
      Delete(S, i, 1);
  // ungültige Zahlen entfernen
  while (i > 0) and (S[i] in ['0'..'9']) do
    Dec(i);
  for i := i downto 1 do
    if (S[i] in ['0'..'9']) then
      Delete(S, i, 1);
  //
  SL := TStringList.Create;
  try
    US.s := [];
    repeat
      U := 0;
      // String aufsplitten
      SL.LineBreak := '';
      SL.Delimiter := ' ';
      SL.StrictDelimiter := True;
      SL.DelimitedText := S;
      // längstes Wort suchen + Capitalize
      i2 := 0;
      for i := SL.Count -1 downto 0 do begin
        SL[i] := UpperCase(Copy(SL[i], 1, 1)) + LowerCase(Copy(SL[i], 2));
        i2 := Max(i2, Length(SL[i]));
      end;
      // Anzahl der zu entfernenden Zeichen
      Len := Length(SL.Text) - Len;
      // kurze Wörter (Einzelbuchstaben) entfernen
      i := SL.Count - 1;
      while (Len > 0) and (i >= 0) do begin
        if Length(SL[i]) = 1 then begin
          if not (U in US.s) then begin
            SL.Delete(i);
            Dec(Len);
          end;
          Inc(U);
        end;
        Dec(i);
      end;
      // Wörter kürzen
      i := -1;
      while (Len > 0) do begin
        if i < 0 then begin
          i := SL.Count - 1;
          Dec(i2);
        end;
        if Length(SL[i]) > i2 then begin
          if not (U in US.s) then begin
            SL[i] := Copy(SL[i], 1, i2) + Copy(SL[i], i2 + 2);
            Dec(Len);
          end;
          Inc(U);
        end;
        Dec(i);
      end;
      // nächstes Set, für's Überspringen
      Inc(US.i);
      // Text zusammensetzen und ausgeben
      Result := SL.Text;
    until Erlaubt(Result);
  finally
    SL.Free;
  end;
end;

[BBoy]

@himitsu,
Bei

Delphi-Quellcode:

          if not (U in US) then begin

kommt "[DCC Fehler] Unit2.pas(2299): E2015 Operator ist auf diesen Operandentyp nicht anwendbar" das soll wohl us.s heißen, oder?

und am ende das until

Delphi-Quellcode:

 until Erlaubt(Result);

kann auch nicht stimmen, wie soll das richtig heißen?


@mkinzler, das würde mir auch genügen. Werde das später mal testen.

Noch mal vielen Dank ihr beiden....

[himitsu]

.s = jupp

und das Until sollte so stimmen ... Wieso, was stimmt denn daran nicht?

[BBoy]

Sorry, aber mal ganz blöd gefragt, wie rufe ich diese funktion auf?

memo1.text := KuerzeDateiname(edit1.Text,14, ??) < was kommt da hin?

[mkinzler]

Eine Funktion, welche wagr oder falsch zurückliefert, je nachdem ob gekürzt werden darf oder nicht

[BBoy]

Sowas hatte ich noch nie :? Das verstehe ich jetzt gar nicht. Ein False oder True ist es nicht. Was soll ich denn in diese funktion schreiben?

[mkinzler]

Die Funktion bekommt den aktuellen String als parameter. Anhand diesem muss sie entscheiden, ob dieser ok ist.

Delphi-Quellcode:

function SchonOK( s: string): Boolean;
begin
   ...
end;

...
memo1.text := KuerzeDateiname(edit1.Text,14, SchonOK);

[BBoy]

OK, dort überprüfe ich dann z.B. ob de Name schon vorhanden ist. Das funktioniert alles gut.
Nur ist mir aufgefallen das Zahlen am Ende nicht berücksichtigt werden. Aus "Bellenkrappen Mannheim 2" macht er "BellenkMannhei" aber zahlen am Ende müssen immer erhalten bleiben.
Wie könnte man das in der Version von himitsu noch nachbessern?
thx

Ich glaube es liegt daran das kurze wörter gelöscht werden. So wird also eine ziffer als zu kurz gewertet und gelöscht:

Delphi-Quellcode:

        if Length(SL[i]) = 1 then begin
          if not (U in US.s) then begin
            SL.Delete(i);
            Dec(Len);
          end;

zu was ist eigentlich der Record US da?

[mkinzler]

Übernehme den Teil aus meiner Version

[BBoy]

Cool, das funktioniert sogar :)

Nur damit ich es auch verstehe, zu was ist eigentlich der Record US da?

Nochmal vieeeeelen Dank an euch zwei!! Die Funktion macht nun genau das was sie soll und das sogar besser als erwartet :-D

[himitsu]

Das ist eine Bitmaske, wenn ein Name schon vorhanden ist, dann werden über diese Maske, beim nächsten Durchgang, Löschaktionen übersprungen, so daß ein anderer Name entsteht.

Obwohl noch ein

Delphi-Quellcode:

i := Length(S);

bei

Delphi-Quellcode:

// ungültige Zahlen entfernen

fehlt, sollte dennoch die Zahl erhalten bleiben, da das Ganze ohne mit 0 initialisiert würde (durch die vorherige For-Schleife) :gruebel:

[edit]
ah, hatte hier nur eine zweistellige Zahl drin, wlche erfolgreich durchkam :wall:

Delphi-Quellcode:

type TKueDatErlaubt = function(S: String): Boolean;

function KuerzeDateiname(S: String; Len: Integer; Erlaubt: TKueDatErlaubt): String;
var
  i, i2, u: Integer;
  SL: TStrings;
  US: record
    case Integer of
      0: (i: Int64);
      1: (s: Set of 0..63);
  end;
begin
  // ungültige Zeichen entfernen
  for i := Length(S) downto 1 do
    if not (S[i] in [' ', 'a'..'z', 'A'..'Z', '0'..'9']) then
      Delete(S, i, 1);
  // ungültige Zahlen entfernen
  i := Length(S);
  while (i > 0) and (S[i] in ['0'..'9']) do
    Dec(i);
  for i := i downto 1 do
    if (S[i] in ['0'..'9']) then
      Delete(S, i, 1);
  //
  SL := TStringList.Create;
  try
    US.s := [];
    repeat
      U := 0;
      // String aufsplitten
      SL.LineBreak := '';
      SL.Delimiter := ' ';
      SL.StrictDelimiter := True;
      SL.DelimitedText := S;
      // längstes Wort suchen + Capitalize
      i2 := 0;
      for i := SL.Count -1 downto 0 do begin
        SL[i] := UpperCase(Copy(SL[i], 1, 1)) + LowerCase(Copy(SL[i], 2));
        i2 := Max(i2, Length(SL[i]));
      end;
      // Anzahl der zu entfernenden Zeichen
      Len := Length(SL.Text) - Len;
      // kurze Wörter (Einzelbuchstaben) entfernen
      i := SL.Count - 1;
      while (Len > 0) and (i >= 0) do begin
        if (Length(SL[i]) = 1) and (SL[i][1] in ['a'..'z', 'A'..'Z']) then begin
          if not (U in US.s) then begin
            SL.Delete(i);
            Dec(Len);
          end;
          Inc(U);
        end;
        Dec(i);
      end;
      // Wörter kürzen
      i := -1;
      while (Len > 0) do begin
        if i < 0 then begin
          i := SL.Count - 1;
          Dec(i2);
        end;
        if Length(SL[i]) > i2 then begin
          if not (U in US.s) then begin
            SL[i] := Copy(SL[i], 1, i2) + Copy(SL[i], i2 + 2);
            Dec(Len);
          end;
          Inc(U);
        end;
        Dec(i);
      end;
      // nächstes Set, für's Überspringen
      Inc(US.i);
      // Text zusammensetzen und ausgeben
      Result := SL.Text;
    until Erlaubt(Result);
  finally
    SL.Free;
  end;
end;

Dürfen die Zahlen eigentlich ebenfalls gekürzt werden?
Längere Zahlen werden es ja aktuell noch.

[sx2008]

Die gestellte Aufgabe ist definitiv ein Job für eine Klasse.
Damit ist es viel einfacher jede Teilaufgabe in einer eigenen Methode zu lösen.
Zudem kann eine Klasse übergreifend benötigte Informationen wie z.B. MaxTotalLen=14, Anzahl der Wörter,
die Zahl am Ende einfach in privaten Feldern speichern.
Die einzelnen Methoden werden kleiner und leichter zu testen, als wenn man Alles in einer einzigen grossen Funktion verarbeitet.

Und überhaupt ist hier das Testen unbedingt nötig.
Man braucht also ein Testbett mit dem man mehrere Wertepaare aus Ein- und Ausgangswerten automatisch überprüfen kann.

[mkinzler]

Der TE war schon mit dem Verständnis meiner Minimallösung überfordert. Imho sollten wir nicht versuchen, eine optimale Lösung zu finden, sondern eine bei der er die Chance hat dise verstehen. In letzter Zeit entsteht aber die Tendenz eine Lösung zu finden, welche den Fragesteller auf jeden Fall überfordert.

[BBoy]

Wie gesagt, bin sehr zufrieden mit der Mischung aus beiden Versionen. Funktioniert 1A und nach einigem grübeln und Studieren habe ich den Code auch verstanden. Also alles bestens. Danke. Habe nun schon hunderte Bezeichnungen auf diese Art gekürzt und es war immer gut. Notfalls könnte ich auch von Hand nach editieren wenn es mal nicht passen sollte.

Zahlen kommen nur selten vor. wenn dann extrem selten höchstens 3 stellig. Wenn überhaupt, dann meist 1-2stellig.