[Back to STRINGS SWAG index] [Back to Main SWAG index] [Original]

    {
        Here is a function some of you may find useful, it tries to find
    misspellings such as "Hello World" and "Hello Wolrd" by comparing 2 strings
    and returning a percent base of 3 tests of how close they match...
    Lemme know if you know of a way to improve upon this.
    }

    {$B-,V-,S-,R-,I-,A+}       { for speed }

    uses dos, crt;

    var
       string_a  : string;
       string_b  : string;    { for the 5 line example at the bottom }

    {------------------------------------------------------------------------}
    { 'InStr' -For use with StrMatcher.                                      }
    {                                                                        }
    {     InStr is just like POS except you may specify a starting position. }
    {                                                                        }
    {------------------------------------------------------------------------}
    function InStr(index : byte; var string1, string2 : string) : byte;
    var
       tempstring : string;
    begin
       tempstring := copy(string2, index, length(string2)-index);
       InStr := pos(string1, tempstring) + index - 1;
    end;

    {------------------------------------------------------------------------}
    { 'StrMatcher' -String Matching Procedure, Written by Kevin Currie, '94  }
    {                                                                        }
    {     StrMatcher accepts two pointers and (w/o case sensitivity) tries   }
    {  to determine how well their strings match.  It then returns a percent }
    {  value of its tests into a shortint.                                   }
    {                                                                        }
    {------------------------------------------------------------------------}
    function strmatcher(var string1, string2 : string) : shortint;
    var
       strn1, strn2, tmpstr1, tmpstr2 : string;
       len1, len2, short : byte;
       stest, which, loop : longint;
       postest1, postest2 : integer;
       perc1, perc2, perc3 : real;
       retval : shortint;
    label
       string_match_100,
       string_match_len;
    begin
       { ---===> Don't yell at me about the goto's, they are there for speed  }
       {         and clarity.  (It's clearer than a HUGE block under an if)   }

       { ---===> UpperCase the strings to see if that is where the difference }
       {         lies, and also to make the other comparisons easier.         }

       strn1 := string1;
       len1 := length(string1);                 { I make backup copies        }
       for loop := 1 to len1 do                 { because var is just another }
          strn1[loop] := upcase(strn1[loop]);   { way of saying pointer...    }
       strn2 := string2;                        { In other words if I didn't  }
       len2 := length(string2);                 { I would modify the original }
       for loop := 1 to len2 do                 { strings...                  }
          strn2[loop] := upcase(strn2[loop]);

       { ---===> See of the capitalized strings match }
       if (strn1 = strn2) then
       begin
          retval := 100;
          goto string_match_100;
       end; {if}

       { ---===> Test 1 checks the occurence of chars from string1     }
       {         against the chars in string2                          }
       stest := 0;
       for loop := 1 to len1 do
       begin
          tmpstr1 := strn1[loop];
          if (pos(tmpstr1, strn2) > 0) then inc(stest);
       end; {for}
       perc2 := stest / len1;
       stest := 0;
       for loop := 1 to len2 do
       begin
          tmpstr2 := strn2[loop];
          if (pos(tmpstr2, strn1) > 0) then inc(stest);
       end; {for}
       perc3 := stest / len2;
       perc1 := (perc3 + perc2) / 2;
       if (perc1 < 0) then perc1 := 0;

       { ---===> Test 2 Adds the Values of all the charcters in the    }
       {         string and then takes a percent of 1 vs 2.            }

       stest := 0;
       which := 0;
       for loop := 1 to len1 do                { ---===> the shl 4's and the  }
          stest := stest + ord(strn1[loop]);   {         shr 2's below are to }
       stest := stest shl 4;                   {         add some more weight }
       for loop := 1 to len2 do                {         to the difference.   }
          which := which + ord(strn2[loop]);
       which := which shl 4;
       loop := stest shr 2;
       if (which > stest) then loop := which shr 2;
       perc2 := 1 - (abs(stest - which) / loop);
       if (perc2 < 0) then perc2 := 0;

       { ---===> Test 3 checks the character position differences between  }
       {         the two strings.                                          }
       {                                                                   }
       {         NOTE:  A string being shorter than another can cause this }
       {                test to fail quite badly so null characters are    }
       {                placed in the shorter string where there are char  }
       {                mismatches until the strings are equal in length.  }

       if (len1 = len2) then goto string_match_len;

       tmpstr1 := '';
       tmpstr2 := '';
          loop :=  1;

       if (len1 > len2) then
       begin
          short := len1 - len2;
          which := 2;
       end else
       begin
          short := len2 - len1;
          which := 1;
       end; {if/else}

       while (short <> 0) do
       begin
          if (strn1[loop] = strn2[loop]) then
          begin
             case which of
                1:   tmpstr1 := tmpstr1 + strn2[loop];
                2:   tmpstr1 := tmpstr1 + strn1[loop];
             end; {case}
          end else
          begin
             case which of
                1:
                begin
                   tmpstr1 := tmpstr1 + #0;
                   tmpstr2 := copy(strn1, loop, (len1-loop)+1);
                     strn1 := concat(tmpstr1, tmpstr2);
                   dec(short);
                end; {case1}
                2:
                begin
                   tmpstr1 := tmpstr1 + #0;
                   tmpstr2 := copy(strn2, loop, (len2-loop)+1);
                     strn2 := concat(tmpstr1, tmpstr2);
                   dec(short);
                end; {case2}
             end; {case}
          end; {if/else}
          inc(loop);
       end; {while}

       len1 := length(strn1);      { ---===> Reset these after the loop that }
       len2 := length(strn2);      {         makes them the same length.     }

     string_match_len: {label}

       { ---===> Now that we have the string lengths the same lets check the }
       {         character positions.                                        }

       stest := 0;
       for loop := 1 to len1 do
          stest := stest + loop + loop - 1;
       which := stest;
       for loop := 1 to len1 do
       begin
          tmpstr1  := strn1[loop];
          tmpstr2  := strn2[loop];
          postest1 :=  len1 - abs(instr(loop, tmpstr2, strn1));
          postest2 :=  len2 - abs(instr(loop, tmpstr2, strn2));
          stest    := stest - (postest1 + postest2);
       end;
       stest := which - abs(stest);
       which := which + (len1 div 2);
       perc3 := stest / which;
       if (perc3 < 0) then perc3 := 0;

       { ---===> Average the results of the 3 tests.         }
       {         They are weighted hence the 80, 10 and 10.  }

       retval := trunc(((perc1 * 80) + (perc2 * 10) + (perc3 * 10)));

    string_match_100: {label}

       strmatcher := retval; { ---===> Return Percent Difference. }
    end; {StrMatcher}

    begin       { ---===> Stupid 5 line example. }
       clrscr;
       string_a := 'Hello World';
       string_b := 'Hello Wolrd';
       writeln('String Match Percent:', strmatcher(string_a, string_b):5);
       readln;
    end. {main} { ---===> hey, I use C also :-)  }

[Back to STRINGS SWAG index] [Back to Main SWAG index] [Original]