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

{
[marcus is looking for an algorithm, which handles finding strings like
german names, which sometimes are written with "umlauts" and sometimes
not]

the solution for your problem is the soundex-algo.:

if, for example you have to index a database on strings, you normally
would get an alphanumeric sequence by asciicode. instead the soundex will
sort your records on a more phonetic way:
}

(* procedure : soundex.pro
   purpose   : search for similar sounding strings
   compiler  : => tp 4.0
   date      : 14.07.91
 *)


Type
   Lstring = String[255];
Var
   CK_Name1,CK_Name2 : Lstring;


{
convert str to uppercase, careful, doesn't work with umlauts
this function from swag does:
Function UpCaseStr(St : string) : String;
var
  regs : registers;
begin
  Regs.DS := Seg(st[1]);
  Regs.DX := Ofs(st[1]);
  Regs.CX := Length(st);
  Regs.AX := $6521;
  MsDos(Regs);
  UpCaseStr := St;
end;
}


Procedure To_upper (Var str : Lstring);
Var
   I : Integer;

Begin
   For I := 1 to Length (str) do
      str [I] := upcase (str[I]);

End  {  To_Upper  };

{ remove all occurances of double letters like wie oo,tt,ee, etc. }

Procedure eliminate_doubles (Var str : lstring);
Var
   I,J : Integer;
Begin
   For I := 1 to Length (str) do
      Begin
      If str [I] = str [I + 1] then
         Begin
         For J := I + 1 to Length (str)-1 do
            str [J] := str [J + 1];
         End
      End
End  {  eliminate_doubles  };

{ Code 'Code' for soundex comparison }

Procedure Sound_Ex (var Code : Lstring);
Var
   I : Integer;
   Sndex : Lstring;

Begin
   Sndex := '';
   Sndex := Sndex + Code [1];
   For I := 2 to Length (Code) do
      Begin
      Case Code [I] of
         'B','F','P','V'                 : Sndex := Sndex +  '1';
         'C','G','J','K','Q','S','S','Z' : Sndex := Sndex +  '2';
         'D','T'                         : Sndex := Sndex +  '3';
         'L'                             : Sndex := Sndex +  '4';
         'M','N'                         : Sndex := Sndex +  '5';
         'R'                             : Sndex := Sndex +  '6';
      End { case };
      End { For };
   If Length (Sndex) > 4 then Sndex := Copy (Sndex,1,4);
   If Length (Sndex) < 4 then
      For I := Length (Sndex) to 3 do Sndex := Sndex + '0';
   Code := Sndex;

End  {  Sound_Ex  };

{**************************************************
 * returns TRUE, if Name1 in Soundexcode          *
 * ressembles to Name2, returns falsch, if not    *
 **************************************************}

Function Sounds_Like (Name1,Name2 : Lstring) : Boolean;
Var
   Tnam1,Tnam2 : Lstring;

Begin
   Tnam1 := Name1;
   Tnam2 := Name2;
   To_Upper (Tnam1);
   To_Upper (Tnam2);
   eliminate_doubles (Tnam1);
   eliminate_doubles (Tnam2);
   Sound_Ex (Tnam1);
   Sound_Ex (Tnam2);
Writeln;
Writeln ('> ',Tnam1,' <> ',tnam2,' <');
   If Tnam1 = Tnam2 then
      Sounds_Like := TRUE
   Else
      Sounds_Like := FALSE;

End  {  Sounds_Like  };



{
*******************
*    DEMO         *
*******************
}


Begin
   Write ('1. Name please: ');Readln (CK_Name1);
   Write ('2. Name please: ');Readln (CK_Name2);
   Writeln;Writeln;
   Writeln (CK_Name1,' and ',CK_Name2);
   If Sounds_Like (CK_Name1,CK_Name2) Then
      Writeln (' sound ALIKE !')
   Else
      Writeln (' do not sound alike at all !');

End.                          

{
the used chars are languagedependant and should be used according to the
distribution of their occurances in the used language. you have to trick
around a bit with them, until you'll get the best result. those above
should work fine for the english language (which again is spoken in this
echo ;-) ).
}

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