unit junior_u;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls,math;
const
  Buchstaben=['a'..'z', 'A'..'Z', 'ä', 'ö', 'ü', 'Ä', 'Ö', 'Ü', 'ß',''''];
type
  PNextWord=^TWord;
  TWord = record
    word:string;
    len:integer;
    firstChars,lastChars:cardinal;
    alreadyUsed:boolean;
    nextWords:array of PNextWord;
    nextWordStrings:array of pchar;
  end;
  TWords=array of TWord;
  TForm1 = class(TForm)
    Panel1: TPanel;
    Memo1: TMemo;
    Label1: TLabel;
    CheckBox1: TCheckBox;
    Button1: TButton;
    Panel2: TPanel;
    Edit1: TEdit;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    Edit2: TEdit;
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen}
  public
    { Public-Deklarationen}
  end;

var
  Form1: TForm1;
implementation

{$R *.DFM}
//Sucht die längste Wort-Kette mit Wörtern aus dem übergebenen Text
function findLongestWordKette(const text:string;useOften:boolean=false;
                              exactThreeChars:boolean=true;minimalLength:integer=3):string;
  //Vergleicht zwei Strings und gibt true zurück wenn der Postfixe von s1 mit einer
  //Länge >= minimal mit dem Präfix der selben von s2 übereingstimmt
  //Und gibt einen Pointer auf das Zeichen nach dem Präfix zurück
  function compare(const s1,s2:string; minimal:integer;out startpos:pchar):boolean;
  var i,j,len1:integer;
  begin
    len1:=length(s1);
    result:=false;
    startpos:=nil;
    for i:=minimal to min(len1,length(s2)) do begin
      //Letzte i vergleichen
      result:=true;
      for j:=0 to i-1 do
        if s1[len1-j]<>s2[i-j] then begin
          result:=false;
          break;
        end;
      if Result then begin //OK? Kein unterschied?
        startpos:=@s2[i+1];
        break;
      end;
    end;
  end;
  //rekursive Routine zur Suche
  function rekFindLongest(var lastWord:TWord; const str:string):string;
  var i:integer;
      new:string;
  begin
    lastWord.alreadyUsed:=true; //mehrmaliges durchlaufen des selben Wortes
    result:=str;                    //in der gleichen Kette verhindern
    for i:=0 to high(lastWord.nextWords) do //Durchlaufe alle Nachfolger
      if not lastWord.nextWords[i]^.alreadyUsed then begin
        new:=rekFindLongest(lastWord.nextWords[i]^,str+ //Wort übergeben
                            string(lastWord.nextWordStrings[i])); //und String
                                                                  //zusammensetzen
        if length(new)>length(result) then result:=new;
      end;
    lastWord.alreadyUsed:=false; //für nächste Kette freigeben
  end;
var i,j,k:integer;
    textLen:integer;
    words:TWords;
    startpos:pchar;
    new:string;
begin
  //Wörter aus dem Text in eine Liste einfügen
  SetLength(words,0);
  i:=1;
  textLen:=length(text);
  while i<=textLen do //Text durchlaufen bis zum ersten  Buchstaben
    if text[i]in buchstaben then begin
      j:=i+1;
      while (text[j] in buchstaben) do inc(j);
      //j-i ist die Wortlänge
      if (j-i)<=3 then begin
        i:=j;
        continue;
      end;
      SetLength(words,length(words)+1);
      with words[high(words)] do begin
        len:=j-i;
        //Wort kopieren und in Kleinbuchstaben umwandeln
        SetLength(word,len);
        for k:=1 to len do
          case text[i+k-1] of
            'A'..'Z': word[k]:=chr(ord(text[i+k-1])+(ord('a')-ord('A')));
            'Ö': word[k]:='ö';
            'Ä': word[k]:='ä';
            'Ü': word[k]:='ü';
            else word[k]:=text[i+k-1];
          end;

        if not useOften then begin //Mehrmals vorkommende Wörte mehmals nutzen?
          for k:=0 to high(words)-1 do //suchen
            if words[k].word=word then begin
              SetLength(words,high(words)); //Wort wieder löschen, bereits da
              i:=j;
              break;
            end;
          if i=j then continue;
        end;

        //Buchstaben merken
        if exactThreeChars then begin //Genau 3 Buchstaben Prä/Post-fixe?
          firstChars:=(ord(word[1]) shl 16) or (ord(word[2]) shl 8) or ord(word[3]);
          lastChars:=(ord(word[len-2]) shl 16) or (ord(word[len-1]) shl 8) or ord(word[len]);
        end;
        //restliche initialisieren
        alreadyUsed:=false;
        SetLength(nextWords,0);
        SetLength(nextWordStrings,0);
      end;
      i:=j;
    end else inc(i);

  //Feststellen, welche Wörter an welche anhängbar sind
  startpos:=nil;
  for i:=0 to high(words) do
    for j:=0 to high(words) do
      if (i<>j)and((exactThreeChars and (words[i].lastChars=words[j].firstChars))
                  or ((not exactThreeChars) and
                      compare(words[i].word,words[j].word,minimalLength,startpos)))
      then begin
        //nachfolgendes Wort speichern
        SetLength(words[i].nextWords,length(words[i].nextWords)+1);
        SetLength(words[i].nextWordStrings,length(words[i].nextWordStrings)+1);
        words[i].nextWords[high(words[i].nextWords)]:=@words[j];
        if exactThreeChars then words[i].nextWordStrings[high(words[i].nextWordStrings)]:=@words[j].word[4]
        else words[i].nextWordStrings[high(words[i].nextWordStrings)]:=startpos;
      end;

  //Rekursiven Aufruf starten
  Result:='';
  for i:=0 to high(words) do begin
    new:=rekFindLongest(words[i],words[i].word);
    if length(new)>length(result) then result:=new;
  end;
end;
//wichtigste, da einzigste, Interaktionsroutine für das grafische Ein- und Aus-
//gabesystem
procedure TForm1.Button1Click(Sender: TObject);
begin
  edit1.text:=findLongestWordKette(memo1.lines.text,CheckBox1.Checked,RadioButton1.Checked,StrToIntDef(edit2.text,3));
  ShowMessage(edit1.text);
end;

end.
