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 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
  // einer von beiden oder beide null, dann wech
 if (length(S1)=0 )or(length(S2)=0) then 
   result:=0 // alternativ kann hier noch unterschieden werden, welcher null ist
 else begin
 // 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
 // division durch null muss abgefangen werden!!
 try
   Result:= 100 * hit DIV l1;
 except
   result:=100;
 end;
end;
end;                    

1:
2:

uses
  Math;