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:

function Tdbl.compareMyStrings(_S1, _S2: String): integer;
var hit: Integer; // Number of identical chars
    p1, p2: Integer; // Position count
    l1, l2: Integer; // Length of strings
    pt: Integer; // for counter
    diff: Integer; // unsharp factor
    hstr: string; // help var for swapping strings
    // Array shows is position is already tested
    test: array [1..255] of Boolean;
    S1,S2: String;
begin
 S1:= UpperCase(trim(_S1)); // normalize
 S2:= UpperCase(trim(_S2)); // dito
 if (length(S1)=0 )or(length(S2)=0) then begin
   result:=100;
   exit;
 end;
 // Test Length and swap, if s1 is smaller
 // we alway search along the longer string
 if Length(s1) < Length(s2) then begin
  hstr:= s2; s2:= s1; s1:= hstr;
 end;
 // store length of strings to speed up the function
 l1:= Length (s1);
 l2:= Length (s2);
 p1:= 1; p2:= 1; hit:= 0;
 // calc the unsharp factor depending on the length
 // of the strings. Its about a third of the length
 diff:= Max (l1, l2) div 3 + ABS (l1 - l2);
 // init the test array
 for pt:= 1 to l1 do test[pt]:= False;
 // loop through the string
 repeat
  // position tested?
  if not test[p1] then begin
   // found a matching character?
   if (s1[p1] = s2[p2]) and (ABS(p1-p2) <= diff) then begin
    test[p1]:= True;
    Inc (hit); // increment the hit count
    // next positions
    Inc (p1); Inc (p2);
    if p1 > l1 then p1:= 1;
   end else begin
    // Set test array
    test[p1]:= False;
    Inc (p1);
    // Loop back to next test position if end of the string
    if p1 > l1 then begin
     while (p1 > 1) and not (test[p1]) do Dec (p1);
     Inc (p2)
    end;
   end;
  end else begin
   Inc (p1);
   // Loop back to next test position if end of string
   if p1 > l1 then begin
    repeat Dec (p1); until (p1 = 1) or test[p1];
    Inc (p2);
   end;
  end;
 until p2 > Length(s2);
 // calc procentual value
 try
   Result:= 100 * hit DIV l1;
 except
   result:=100;
 end;
end;					

1:

diff:= Max (l1, l2) div 3 + ABS (l1 - l2);					

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:

function CompareStrings(S1: string; S2: string): Real;
var
  LenA, LenB, i, fAlphas: Integer;
  h: string;
begin
  fAlphas := 0;
  LenA := Length(S1);
  LenB := Length(S2);
  If ((LenA = 0) and (LenB > 0)) or ((LenB = 0) and (LenA > 0)) Then
  begin
    CompareStrings := 0;
    exit;
  end
  Else
    If (LenA = 0) and (LenB = 0) Then
    begin
      CompareStrings := 1;
      exit;
    end;
  If LenB > LenA Then
  begin
    h := S1;
    S1 := S2;
    S2 := h;
    i := LenA;
    LenA := LenB;
    LenB := i;
  end;
  For i := 1 to LenA do
    If S1[i] <> S2[i] Then Inc(fAlphas);
  If fAlphas > LenA Then
    CompareStrings := 0
  else
    CompareStrings := LenA / (LenA + fAlphas);
end;					

1:

If ord(S1[i]) <> ord(S2[i]) Then Inc(fAlphas);					

1:

If LowerCase(S1[i]) <> LowerCase(S2[i]) Then Inc(fAlphas);					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:

 
  If LenB > LenA Then  
  begin  
    h := S1;  
    S1 := S2;  
    S2 := h;  
    i := LenA;  
    LenA := LenB;  
    LenB := i;  
  end;					

1:
2:
3:
4:

For i := 1 to LenB do
begin
  If S2[i] = '' Then S2[i] := ' '; // *
end;					

1:

SetLength(ShorterString, Length(LongerString));					

1:

SetLength(S2, Length(S1));					

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:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
  FiR0 : integer;
  FiP0 : integer;
  FiQ0 : integer;


implementation

{$R *.DFM}

function Min(X,Y,Z: Integer): Integer;
begin
 if (X<Y) then Result:=X else Result:=Y;
  if (Result>Z) then Result:=Z;
end;


procedure LevenshteinPQR(p,q,r:integer);
begin
 FiP0 := p;
 FiQ0 := q;
 FiR0 := r;
end;


function LevenshteinDistance(const sString,sPattern: String): Integer;
const
  MAX_SIZE = 50;
var
  aiDistance: array [0..MAX_SIZE,0..MAX_SIZE] of Integer;
  i,j,iStringLength,iPatternLength,iMaxI,iMaxJ: Integer;
 chChar: Char;
  iP,iQ,iR,iPP: Integer;
begin
  iStringLength:=length(sString);
  if (iStringLength>MAX_SIZE) then iMaxI:=MAX_SIZE else
iMaxI:=iStringLength;
 iPatternLength:=length(sPattern);
  if (iPatternLength>MAX_SIZE) then iMaxJ:=MAX_SIZE else
iMaxJ:=iPatternLength;

  aiDistance[0,0]:=0;
 for i:=1 to iMaxI do aiDistance[i,0]:=aiDistance[i-1,0]+FiR0;

 for j:=1 to iMaxJ do begin
   chChar:=sPattern[j];
   if ((chChar='*') or (chChar='?')) then iP:=0 else iP:=FiP0;
   if (chChar='*') then iQ:=0 else iQ:=FiQ0;
   if (chChar='*') then iR:=0 else iR:=FiR0;

   aiDistance[0,j]:=aiDistance[0,j-1]+iQ;

   for i:=1 to iMaxI do begin
   if (sString[i]=sPattern[j]) then iPP:=0 else iPP:=iP;
   {*** aiDistance[i,j] := Minimum of 3 values ***}
   aiDistance[i,j]:=Min(aiDistance[i-1,j-1]+iPP,
        aiDistance[i,j-1]  +iQ ,
        aiDistance[i-1,j]  +iR);
  end;
 end;
 Result:=aiDistance[iMaxI,iMaxJ];
end;




procedure TForm1.Button1Click(Sender: TObject);
begin
 LevenshteinPQR(1,2,2);
 showmessage(inttostr(LevenshteinDistance('falsch','f*lsch')));
 showmessage(inttostr(LevenshteinDistance('falsch','falach')));
 showmessage(inttostr(LevenshteinDistance('falsch','fasch')));
end;

end.