Funcao - soudex

// retorna o codigo em "SOM" de uma palavra.

// ex.:

//      JUNIOR e GUNIOR retorno é igual

//      LUIS e LUIZ     tambem...

function Soundex(strPalavra: string): string;

var

  strTmpPalavra1: string;

  strTmpPalavra2: string;

  c             : string[1];

  chrLetra1,

  chrLetra2     : array[0..1] of char;

  x             : integer;

const

  setVogais: set of 'A' .. 'Z' = ['A', 'E', 'I', 'O', 'U', 'Y', 'W'];

begin

  Result          := '';

  strTmpPalavra1  := '';

  strTmpPalavra2  := '';

  if strPalavra = '' then exit;

  // Separar letras "úteis" da palavra

  for x := 1 to length(strPalavra) do

  begin

    c := UpperCase(copy(strPalavra, x, 1));

    StrPCopy(chrLetra1, copy(strPalavra, x, 1));

    case chrLetra1[0] of

      'ç','Ç'                         : strTmpPalavra1 := strTmpPalavra1 + 'C';

      'Á','á','À','à','Â','â'         : strTmpPalavra1 := strTmpPalavra1 + 'A';

      'É','é','È','è','Ê','ê'         : strTmpPalavra1 := strTmpPalavra1 + 'E';

      'Í','í','Ì','ì','Î','î'         : strTmpPalavra1 := strTmpPalavra1 + 'I';

      'Ó','ó','Ò','ò','Ô','ô'         : strTmpPalavra1 := strTmpPalavra1 + 'O';

      'Ú','ú','Ù','ù','Û','û','Ü','ü' : strTmpPalavra1 := strTmpPalavra1 + 'U';

      else if ((c >= 'A') and (c <= 'Z')) then strTmpPalavra1 := strTmpPalavra1 + c;

    end;

  end;

  // Tirar letras duplicadas

  strTmpPalavra2  := strTmpPalavra1;

  strTmpPalavra1  := EmptyStr;

  for x := 1 to length(strTmpPalavra2) do

    if (copy(strTmpPalavra2, x, 1) <> copy(strTmpPalavra2, x + 1, 1)) then

      strTmpPalavra1 := strTmpPalavra1 + copy(strTmpPalavra2, x, 1);

  // Tirar pares de vogais

  strTmpPalavra2  := strTmpPalavra1;

  strTmpPalavra1  := EmptyStr;

  for x := 1 to length(strTmpPalavra2) do

  begin

    StrPCopy(chrLetra1, copy(strTmpPalavra2, x, 1));

    StrPCopy(chrLetra2, copy(strTmpPalavra2, x + 1, 1));

    if not ((chrLetra1[0] in setVogais) and

            (chrLetra2[0] in setVogais)) then

      strTmpPalavra1 := strTmpPalavra1 + copy(strTmpPalavra2, x, 1);

  end;

  // Tratar pares de consoantes

  strTmpPalavra2  := strTmpPalavra1;

  strTmpPalavra1  := EmptyStr;

  x := 1;

  while x <= length(strTmpPalavra2) do

  begin

    StrPCopy(chrLetra1, copy(strTmpPalavra2, x, 1));

    StrPCopy(chrLetra2, copy(strTmpPalavra2, x + 1, 1));

    if (not (chrLetra1[0] in setVogais) and not (chrLetra2[0] in setVogais)) then

    begin

      if (chrLetra1 = 'B') or (chrLetra1 = 'D') or (chrLetra1 = 'S') or (chrLetra1 = 'X') then

      begin

        strTmpPalavra1 := strTmpPalavra1 + copy(strTmpPalavra2, x + 1, 1);

        inc(x);

      end

      else

        strTmpPalavra1 := strTmpPalavra1 + copy(strTmpPalavra2, x, 1);

      inc(x);

    end

    else strTmpPalavra1 := strTmpPalavra1 + copy(strTmpPalavra2, x, 1);

    inc(x);

  end;

  // Atribuir código às letras restantes

  strTmpPalavra2  := strTmpPalavra1;

  strTmpPalavra1  := EmptyStr;

  for x := 1 to length(strTmpPalavra2) do

  begin

    StrPCopy(chrLetra1, copy(strTmpPalavra2, x, 1));

    case chrLetra1[0] of

      'A','E','I','Y','O','U','W'     : strTmpPalavra1 := strTmpPalavra1 + '1';

      'B','F','P','V','L','R'         : strTmpPalavra1 := strTmpPalavra1 + '2';

      'C','G','J','K','Q','S','X','Z' : strTmpPalavra1 := strTmpPalavra1 + '3';

      'D','T','M','N'                 : strTmpPalavra1 := strTmpPalavra1 + '4';

    end;

  end;

  // Atribuir o código ao resultado

  Result:= Copy(strTmpPalavra1 + '00000000', 1, 8);

end;