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;