DBR Delphi-Ecke

// Schon zu Zeiten von dBase gab es einen "Soundex"-Algorithmus, mit dem man zwei
// Strings auf Ähnlichkeit testen konnte. Allerdings gefiel mir das Ganze nicht so
// richtig, da bestimmte Buchstaben (Vokale, Umlaute, H, W, Y) ausgespart werden,
// während andere zusammengefasst werden (z.B.: C, G, J, K, Q, S, X, Z). Das bringt
// zwar einen hohen Geschwindigkeitsvorteil beim Durchsuchen von großen
// Datenbeständen, jedoch im Deutschen nicht immer das gewünschte Ergebnis.
// Sucht man beispielsweise das Wort "Rechner" findet man auch "Rosemarie" und
// bei der Suche nach "Bart" findet man auch "Broadway". Andererseits findet man
// den Familiennamen "Flugbeil" nie, wenn man nach "Pflugbeil" sucht. Deshalb
// habe ich die Funktion "Umwandeln" (Punkt 2) geschrieben.

// Getestet mit D4 unter XP

//(RS 10.4 unter W11 siehe unten Punkt 4 Ähnlichkeit)

// Punkt 1. Soundex
// Umsetzung des Soundex-Algorithmus nach Delphi:

// Vergleichsbeispiele:
// String 1     String 2      ähnlich (oder gleich)
// Haustür      Haustier      True
// Mieze        Mütze         False
// Waldzwerg    Walzwerk      False
// Pferd        fährt         False
// Gombjuda     Computer      False

function Soundex(s: string): string; 
var 
  x: integer; 
  procedure add(c: string); 
  begin 
    if (Ansilastchar(Result) <> c) 
      then Result := Result + c; 
  end; 
begin 
  if s = '' then Result := '' 
  else begin 
    s := Ansiuppercase(s); 
    Result := s[1]; 
    for x := 2 to length(s) do 
      case s[x] of 
        'B', 'F', 'P', 'V': add('1'); 
        'C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z': add('2'); 
        'D', 'T': add('3'); 
        'L': add('4'); 
        'M', 'N': add('5'); 
        'R': add('6'); 
      end; 
  end; 
end; 
 

// Beispielaufruf 
 
function vergleiche(s1, s2: string): boolean; 
begin 
  Result := Soundex(s1) = Soundex(s2); 
end; 
 
procedure TForm1.Button7Click(Sender: TObject); 
begin 
  if vergleiche('Schneider', 'Schnayter') 
    then showmessage('passt') 
  else showmessage('passt nicht'); 
end;

//--------------------------------------------------------------------

// Punkt 2. Phonetic
// Es muss zunächst der Suchbegriff umgewandelt und dann mit dem jeweiligen
// umgewandelten zu testenden Begriff verglichen werden.
// Bei Datenbanken sollte man zum schnelleren Finden ein zusätzliches Feld
// einrichten und schon zum Zeitpunkt der Eingabe das Feld mit dem zu
// vergleichenden Begriff (z.B. bereits umgewandelter Familienname) füllen.

// Beispiele:
// Suchbegriff          phonetisch gefunden
// Haustür              Haustür, Haustier
// Mieze                Mieze, Mütze
// Waldzwerg            Waldzwerg, Walzwerk
// Bäcker               Bäcker, Bekker, Baecker
// Pferd                Pferd, fährt
// Voigt                Vogt, Voigt
// Gombjuda             Computer

function Umwandeln(s: string): string; 
const 
  em = ['E', 'Ö', 'Ä']; 
var 
  x, lg: integer; 
  function bds(r: string): string; 
  var i: integer; 
  begin 
    i := length(r); 
    if (i > 1) and (copy(r, i - 2, 2) = 'DS') 
      then result := '' else result := 'DS'; 
  end;
  function bei_C: string; 
  begin 
    case s[x + 1] of 
      #0: begin 
          if x = 1 then 
            result := 'G' else 
            result := 'S'; 
          inc(x); 
        end; 
      'K': begin 
          result := 'G'; 
          inc(x, 2); 
        end; 
      'H': if s[x + 2] = 'S' then begin 
          result := 'GS'; 
          inc(x, 3); 
        end else begin 
          result := 'S'; 
          inc(x, 2); 
        end; 
    else begin 
        result := 'G'; 
        inc(x); 
      end; 
    end; 
  end;
  function bei_S: string; 
  begin 
    result := 'S'; 
    if copy(s, x + 1, 2) = 'CH' then 
      inc(x, 3) else inc(x); 
  end; 
  function bei_A: string; 
  begin 
    case s[x + 1] of 
      'I', 'Y': begin 
          result := 'EJ'; 
          inc(x, 2); 
        end; 
      'U': begin 
          result := 'OV'; 
          inc(x, 2); 
        end; 
      'E': begin 
          inc(x, 2); 
          while s[x] in em do inc(x); 
          if s[x] = 'R' then begin 
            while s[x] = 'R' do inc(x); 
            result := 'A'; 
          end else result := 'E'; 
        end; 
    else begin 
        result := 'A'; 
        inc(x); 
      end; 
    end; 
  end; 
  function bei_O: string; 
    procedure nuro(i: integer); 
    begin 
      result := 'O'; 
      inc(x, i); 
    end; 
  begin 
    case s[x + 1] of 
      'I': begin 
          if s[x + 2] = 'G' then nuro(2) 
          else begin 
            result := 'JU'; 
            inc(x, 2); 
          end; 
        end; 
      'E': begin 
          result := 'E'; 
          inc(x, 2); 
        end; 
    else nuro(1); 
    end; 
  end; 
  function bei_E(r: string): string; 
  begin 
    while s[x + 1] in em do inc(x); 
    case s[x + 1] of 
      'I', 'Y': begin 
          result := 'EJ'; 
          inc(x, 2); 
        end; 
      'W', 'U': begin 
          result := 'JU'; 
          inc(x, 2); 
        end; 
      'R': begin 
          while s[x + 2] = 'R' do inc(x); 
          if (length(r) > 2) or (s[x + 2] = #0) or (s[x + 2] = #32) then begin 
            result := 'A'; 
            inc(x, 2); 
          end else begin 
            result := 'E'; 
            inc(x); 
          end; 
        end; 
    else begin 
        if not ((s[x + 2] = #0) and (s[x + 1] in 
          [#67..#68, #70, #71, #75, #76, #81..#84, #86..#88, #90])) 
          then result := 'E'; 
        inc(x); 
      end; 
    end; 
  end; 
  function bei_P: string; 
  begin 
    case s[x + 1] of 
      'F', 'H': begin 
          result := 'V'; 
          inc(x, 2); 
        end; 
    else begin 
        result := 'B'; 
        inc(x); 
      end; 
    end; 
  end; 
  function bei_U: string; 
  begin 
    if s[x + 1] = 'E' then begin 
      result := 'J'; 
      inc(x, 2); 
    end else begin 
      result := 'JU'; 
      inc(x); 
    end; 
  end; 
  function bei_D(r: string): string; 
  begin 
    if s[x + 1] in ['S', 'Z'] then begin 
      result := bds(r); 
      inc(x, 2); 
    end else begin 
      result := 'D'; 
      inc(x); 
    end; 
  end; 
begin 
  result := ''; 
  if s = '' then exit; 
  s := ansiuppercase(trim(s)); 
  lg := length(s); 
  x := 1; 
  while x <= lg do begin 
    case s[x] of 
      #32: inc(x); 
      'C': result := result + bei_C; 
      'S': result := result + bei_S; 
      'A', #192..#195: result := result + bei_A; 
      'O', #210..#213: result := result + bei_O; 
      'U', #217..#219: result := result + bei_U; 
      'E', 'Ä', #200..#202: result := result + bei_E(result); 
      'P': result := result + bei_P; 
      'D', 'T': result := result + bei_D(result); 
      'Z': begin 
          inc(x); 
          result := result + bds(result); 
        end; 
      'H': begin 
          if x = 1 then result := 'H'; 
          inc(x); 
        end; 
      'R': begin 
          if s[x + 1] = #0 then result := result + 'A' 
          else result := result + 'R'; 
          inc(x); 
        end; 
      'I', #204..#206: begin 
          result := result + 'J'; 
          inc(x, ord(s[x + 1] = 'E') + 1); 
        end; 
      'X': begin 
          result := result + 'GS'; 
          inc(x); 
        end; 
      'ß': begin 
          result := result + 'S'; 
          inc(x); 
        end; 
      'K': begin 
          result := result + 'G'; 
          inc(x); 
        end; 
      'F', 'W': begin 
          result := result + 'V'; 
          inc(x); 
        end; 
      'Ö': begin 
          result := result + 'E'; 
          inc(x); 
        end; 
      'Ü', 'Y': begin 
          result := result + 'J'; 
          inc(x); 
        end; 
    else begin 
        result := result + s[x]; 
        inc(x); 
      end; 
    end; 
  end; 
  x := 1; 
  while x < length(result) do begin 
    if result[x] = result[x + 1] then delete(result, x, 1) 
    else inc(x); 
  end; 
end;

// Beispiel, bei dem anhand von Edit1.Text eine Listbox durchsucht wird. 
// Bei jeder Betätigung von "Enter" wird zum nächsten (phonetisch) gefundenen 
// Wort (Zeile) gesprungen.

const 
  p: integer = 0; 
 
function idxof(lb: TListbox; txt: string): boolean; 
var 
  x: integer; 
  u: string; 
begin 
  result := true; 
  u := umwandeln(txt); 
  if u = '' then begin 
    lb.itemindex := -1; 
    exit; 
  end; 
  for x := p to lb.items.count - 1 do begin 
    if ansipos(u, umwandeln(lb.items[x])) > 0 then begin 
      lb.itemindex := x; 
      p := x + 1; 
      exit; 
    end; 
  end; 
  lb.itemindex := -1; 
  result := false; 
end; 
 
procedure TForm1.Edit1Change(Sender: TObject); 
begin 
  p := 0; 
  if not idxof(listbox1, edit1.text) then 
    showmessage('Begriff nicht gefunden'); 
end; 
 
procedure TForm1.ListBox1Click(Sender: TObject); 
begin 
  p := 0; 
end; 
 
procedure TForm1.ListBox1KeyPress(Sender: TObject; var Key: Char); 
begin 
  p := 0; 
end; 
 
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); 
begin 
  if key = #13 then begin 
    key := #0; 
    if not idxof(listbox1, edit1.text) then begin 
      p := 0; 
      showmessage('Bis zum Ende durchsucht'); 
    end; 
  end; 
end;

// -----------------------------------------------------------------------

// Beispiel zum phonetischen Durchsuchen einer Datenbank (ohne Zusatzfeld). 
// Bei jedem Klick auf den Button wird zum nächsten gefundenen Datensatz 
// gesprungen. Der Suchbegriff steht in Edit1.

const 
  mark: TBookmark = nil; 
  anf: TBookmark = nil; 
 
procedure suchreset(tb: TDataset); 
begin 
  with tb do begin 
    freebookmark(anf); 
    freebookmark(mark); 
    mark := nil; 
    anf := nil; 
  end; 
end; 
 
procedure phonetic(tb: TDataset; feld, s: string); 
begin 
  with tb do begin 
    DisableControls; 
    if mark = nil then begin 
      anf := getbookmark; 
      first; 
      mark := getbookmark; 
    end else begin 
      gotobookmark(mark); 
      next; 
    end; 
    repeat 
      if eof then begin 
        if anf <> nil then 
          gotobookmark(anf); 
        suchreset(tb); 
        showmessage('Bis zum Ende durchsucht'); 
        break; 
      end; 
      if ansipos(s, umwandeln(Fieldvalues[feld])) > 0 
        then begin 
        mark := getbookmark; 
        break; 
      end; 
      next; 
    until false; 
    EnableControls; 
  end; 
end; 
 
procedure TForm1.Edit1Change(Sender: TObject); 
begin 
  if mark <> nil then 
    suchreset(Table1); 
end; 
 
procedure TForm1.Button6Click(Sender: TObject); 
begin 
  if Table1.Active then 
    phonetic(Table1, 'NAME', umwandeln(edit1.text)); 
end;

//--------------------------------------------------------------------

// Punkt 3. Ähnlichkeit
// Während unter Punkt 2 das Hauptgewicht auf den Klang eines Wortes gelegt wurde,
// wird hier die Ähnlichkeit in der Schreibweise geprüft. Natürlich gibt es bei
// den beiden Verfahren eine große Schnittmenge, denn was ähnlich geschrieben wird,
// klingt meistens auch ähnlich. Allerdings fallen hier Konstruktionen wie etwa
// Computer = Gombjuda durch das Raster. Die Ähnlichkeit zweier Strings wird anhand
// ihrer Länge sowie der Gleichheit von Buchstaben an relativer Position geprüft.
// Dabei wird davon ausgegangen, dass zwei Strings ähnlich sind, wenn sie nach den
// genannten Kriterien mindestens zu 51 Prozent übereinstimmen. Ich empfehle eine
// eine Übereinstimmung von 75 Prozent. Vergleichen Sie bitte die folgende Tabelle
// mit der Tabelle unter Punkt 2:

// Beispiele:
// String 1     String 2    Prozent   Ähnlich
// Haustür      Haustier      75        ja
// Mieze        Mütze         75        nein
// Mieze        Mütze         51        ja
// Waldzwerg    Walzwerk      75        ja
// Pferd        fährt         75        nein
// Pferd        fährt         51        nein
// Gombjuda     Computer      51        nein

type 
  Prozent = 51..99; 
 
function vergleiche(s1, s2: string): Integer; 
var 
  x, y, z, ls1, lt: integer; 
  teil: string; 
begin 
  result := 0; 
  if (s1 = '') or (s2 = '') then exit; 
  ls1 := length(s1); 
  for x := ls1 downto 1 do begin 
    for y := 1 to succ(ls1 - x) do begin 
      teil := copy(s1, y, x); 
      z := pos(teil, s2); 
      if z > 0 then begin 
        lt := length(teil); 
        result := lt + vergleiche(copy(s1, y + lt, maxint), copy(s2, 
          z + lt, maxint)) + vergleiche(copy(s1, 1, y - 1), 
          copy(s2, 1, z - 1)); 
        exit; 
      end; 
    end; 
  end; 
end; 
 
function Aehnlich(s1, s2: string; schwelle: Prozent): byte; 
var 
  i: integer; 
begin 
  result := 2; 
  if (s1 = '') and (s2 = '') then exit; 
  i := trunc(200 * (vergleiche(s1, s2)) / (length(s1) + length(s2))); 
  if i < schwelle then result := 0 else 
    if i < 100 then result := 1; 
end; 
 
 
// Diese Beispiel ergibt "Ja, ähnlich!" 
 
procedure TForm1.Button4Click(Sender: TObject); 
var s1, s2: string; 
begin 
  s1 := 'Brettschneider'; 
  s2 := 'Bärschneider'; 
  case Aehnlich(s1, s2, 75) of 
    0: showmessage('Nein, nicht ähnlich!'); 
    1: showmessage('Ja, ähnlich!'); 
    2: showmessage('Nicht nur ähnlich, sondern gleich!'); 
  end; 
end;

//--------------------------------------------------------------------


// Punkt 4. Ähnlich  (neuere Version, aber nicht wie Punkt 2)

uses System.StrUtils; 
 
function Similar(const Str1, Str2: String): Boolean; 
begin 
  Result := SoundexCompare(Str1, Str2, Length(Str1)) = 0; 
end; 
 
procedure TForm1.Button10Click(Sender: TObject); 
begin 
  if Similar('Waldzwerg', 'Walzwerk') then 
    ShowMessage('Ähnlich') 
  else 
    ShowMessage('Unähnlich'); // in diesem Fall 
end; 
 
procedure TForm1.Button11Click(Sender: TObject); 
begin 
  if Similar('Mietze', 'Mütze') then 
    ShowMessage('Ähnlich') // dieses Mal 
  else 
    ShowMessage('Unähnlich'); 
end;