1:
2:
3:

A e r z t e
| | | | | |
Ä r z t e                    

1:
2:

A C(-)D C
A C...D C                    

1:
2:
3:

M o r r i s s e t t e
| | | X X X X X X
M o r i s e t t e                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:

function intCompare(s1, s2: string) :boolean;
// compares wors on a similar content
// (c) retnyg

  function reformat (s:string):string;
  var l,i : integer;
  begin
     l:=length(s);
     result := '';
     for i := 1 to l do
       case upcase(s[i]) of
         'A'..'Z': result := result + upcase(s[i]);
         'Ä','ä': result := result + 'AE';
         'Ö','ö': result := result + 'OE';
         'Ü','ü': result := result + 'UE';
       end;
  end;

type ad = array [0..26] of dword;
var
//    count1, count2: ad;
//    pcount: ^ad;
    usedletters1: string;
    usedletters2: string;
    plen : pinteger;
    i,l,l2:integer;
    p, p2: pstring;

begin
  result := false;

  if (length(s1) = 0) or (length(s2) = 0) then exit;

  s1:=reformat(s1);
  s2:=reformat(s2);

  l := length(s1);
  l2 := length(s2);

//  if (l * 100) div (length(s2) * 100)
  plen := @l;
  p := @s1;
  p2 := @usedletters1;
//  pcount:= @count1;
//  zeromemory(pcount,sizeof(ad));

  setlength(p2^,0);

  for i := 1 to plen^ do begin
     if pos(p^[i],p2^) = 0 then
      p2^ := p2^ + p^[i];
//     inc(count1[ord(p^[i])-65]);
  end;

  plen := @l2;
  p := @s2;
  p2 := @usedletters2;
//  pcount:= @count2;
//  zeromemory(pcount,sizeof(ad));

  setlength(p2^,0);

  for i := 1 to plen^ do begin
     if pos(p^[i],p2^) = 0 then p2^ := p2^ + p^[i];
//     inc(count1[ord(p^[i])-65]);
  end;

  if usedletters1 = usedletters2  then begin result := true; exit; end;

end;                    

1:
2:
3:
4:
5:

procedure TForm1.Button3Click(Sender: TObject);
begin
  if intCompare('Morrisette', 'moriset') then showmessage('same word');
  if intCompare('ärzte', 'Aerzte') then showmessage('same word');
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:

const IgnoreChars :Set of Char = ['.',' ','-','_','´','`','/','~'];

function min2(a,b:integer) : integer;
begin
  if a < b then
    result := a
  else
    result := b;
end;
function min3(a,b,c:integer) : integer;
begin
  if a < b then
    result := min2(a,c)
  else
    result := min2(b,c);
end;


function costChange(c1,c2: char): integer;
begin
  if (AnsiLowerCase(c1)=AnsiLowercase(c2))
    // Umlaute würden ja sonst doppelt bestraft: einmal für a-ä und dann für "e nach nix"
    or ((AnsiLowerCase(c1)='ä') AND (AnsiLowerCase(c2)='a') )
    or ((AnsiLowerCase(c1)='ö') AND (AnsiLowerCase(c2)='o') )
    or ((AnsiLowerCase(c1)='ü') AND (AnsiLowerCase(c2)='ü') )
    or ((AnsiLowerCase(c1)='ß') AND (AnsiLowerCase(c2)='s') )
    or ((AnsiLowerCase(c2)='ä') AND (AnsiLowerCase(c1)='a') )
    or ((AnsiLowerCase(c2)='ö') AND (AnsiLowerCase(c1)='o') )
    or ((AnsiLowerCase(c2)='ü') AND (AnsiLowerCase(c1)='ü') )
    or ((AnsiLowerCase(c2)='ß') AND (AnsiLowerCase(c1)='s') )
    then result := 0
  else result := 1;
end;

function costGap(c1: char):integer;
begin
  if c1 in IgnoreChars then
    result :=0
  else
    result :=1;
end;

function costGap2(c1: char):integer;
begin
  if c1 in IgnoreChars then
    result :=0
  else
    result :=1;
end;

function EditierDistanz(s1,s2: string; tolerance:integer) : integer;
{ Diese Funktion berechnet eine modifizierte Editierdistanz,
  bzw. bricht die Berechnung ab, wenn die Editierdistanz größer
  wird als ein vorgegebener Wert}
var A: array of array of integer;
  i, j, min: integer;
  ls1,ls2:integer;
begin
{ s1: Der String, der gesucht wird
  s2: Der String, in dem gesucht wird
  Array A, was zur Berechnung der Distanz verwendet wird:

      String_in_dem_gesucht_wird
    s 01...                    |
    t  0                       |
    r   0...                   |
    1 .........................X <-Ergebnis }

  ls1 := length(s1);
  ls2 := length(s2);
  setlength(A,ls1+1);
  for i:=0 to length(A)-1 do
  setlength(A[i],ls2+1);

{ Ziel: Der zu suchende String soll in dem anderen möglichst gut enthalten sein
  Daher: Nullte Zeile des Arrays mit 0 initialisieren}
  for j := 0 to ls2 do
    A[0,j] := 0;

{ Änderungen am Suchstring sollen aber bestraft werden
  Daher: Nullte Spalte mit Werten füllen, die u.a. vom char an der betreffenden
        Stelle abhängen }
  for i := 1 to ls1 do
    A[i,0] := A[i-1,0] + costGap(s1[i]);

{ Bedeutung des Parameters 'tolerance':
  Die Editierdistanz kann von oben nach unten nur immer weiter zunehmen
  Wenn man das Minimum der Werte einer Zeile schon größer als die Toleranz ist,
  dann kann abgebrochen werden.}
  min := tolerance + 1;
  for i := 1 to ls1-1 do // Zeilenweise arbeiten
  begin
    min := tolerance + 1;
    for j := 1 to ls2 do // jede Zelle der Zeile durchgehen, davon gibt es |s2| viele
    begin
      A[i,j] := min3(
        A[i-1,j] + costGap2(s1[i]),  // insertion von s1[i] in s2, bzw. löschen in s1
        A[i,j-1] + costGap(s2[j]) ,  // löschen in s2, bzw. insertion in s1, in der letzten Zeil soll das ok sein
        A[i-1,j-1] + costChange(s1[i],s2[j]) );
      if A[i,j] < min then
        min := A[i,j];
    end;
    if min > tolerance then break;
  end;

  if min > tolerance then
  begin
    result := tolerance+1;
    exit;
  end;
{ Die letzte Zeile verdient besondere Aufmerksamkeit:
  Ein löschen von Buchstaben aus dem s2-String soll hier nicht mehr bestraft werden
  -> finde "die toten" in "die toten hosen"}
  for j := 1 to ls2 do
  begin
      A[ls1,j] := min3(
        A[ls1-1,j] + costGap2(s1[ls1]),
        A[ls1,j-1]  , // !!!!
        A[ls1-1,j-1] + costChange(s1[ls1],s2[j]));
  end;
  result := A[ls1,ls2];
end;                    

 
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:

{ ... }
function costGap(c1: char):integer;
begin
  if c1 in IgnoreChars then
    result :=0
  else
    result :=1;
end;

function costGap2(c1: char):integer;
begin
  if c1 in IgnoreChars then
    result :=0
  else
    result :=1;
end;