英文同音算法

下面的函数，返回英文单词的发音标识

{******************************************************}

{* Description: Implementation of Soundex function    *}

{******************************************************}

{* Last Modified : 12-Nov-2000                        *}

{* Author        : Paramjeet Singh Reen               *}

{* eMail         : Paramjeet.Reen@EudoraMail.com      *}

{******************************************************}

{* This program is based on the algorithm that I had  *}

{* found in a magazine. I do not gurantee the fitness *}

{* of this program. Please use it at your own risk.   *}

{******************************************************}

{* Category :Freeware.                                *}

{******************************************************}

unit Soundx;

interface

type

 SoundexStr = String[4];

//Returns the Soundex code for the specified string.

function Soundex(const InpStr :ShortString):SoundexStr;

implementation

const

 Alphs :array['A'..'Z'] of Char = ('0','1','2','3','0','1','2','0','0','2','2',

                                   '4','5','5','0','1','2','6','2','3','0','1',

                                   '0','2','0','2');

function Soundex(const InpStr :ShortString) :SoundexStr;

var

 vStr :ShortString;

 vCh1 :Char;

 i    :Word;

begin

 //Store the given InpStr in local variable in uppercase

 vStr := '';

 for i := 1 to Length(InpStr) do vStr := vStr + UpCase(InpStr[i]);

 //Replace all occurances of "PH" with "F"

 i := Pos('PH',vStr);

 while(i > 0) do

 begin

   Delete(vStr,i,2);

   Insert('F',vStr,i);

   i := Pos('PH',vStr);

 end;

 //Replace all occurances of "CHR" with "CR"

 i := Pos('CHR',vStr);

 while(i > 0) do

 begin

   Delete(vStr,i,3);

   Insert('CR',vStr,i);

   i := Pos('CHR',vStr);

 end;

 //Replace all occurances of "Z" with "S"

 for i := 1 to Length(vStr) do

   if(vStr[i] = 'Z')

     then vStr[i] := 'S';

 //Replace all occurances of "X" with "KS"

 i := Pos('X',vStr);

 while(i > 0) do

 begin

   Delete(vStr,i,1);

   Insert('KS',vStr,i);

   i := Pos('X',vStr);

 end;

 //Remove all adjacent duplicates

 i := 2;

 while(i     if(vStr[i] = vStr[i-1])

     then Delete(vStr,i,1)

     else Inc(i);

 //Starting from 2nd char, remove all chars mapped to '0' in Alphs table

 i := 2;

 while(i     if(Alphs[vStr[i]] = '0')

     then Delete(vStr,i,1)

     else Inc(i);

 //Assemble Soundex string from Alphs table

 vCh1  := vStr[1];

 for i := 1 to Length(vStr) do vStr[i] := Alphs[vStr[i]];

 //Remove all adjacent duplicates from assembled Soundex string

 i := 2;

 while(i     if(vStr[i] = vStr[i-1])

     then Delete(vStr,i,1)

     else Inc(i);

 //Final assembly of Soundex string

 vStr    := vCh1 + Copy(vStr,2,255);

 for i   := Length(vStr) to 3 do vStr := vStr + '0';

 Soundex := vStr;

end;

end.