 |
ActiveDelphi
.: O site do programador Delphi! :.
|
| Exibir mensagem anterior :: Exibir próxima mensagem |
| Autor |
Mensagem |
jjmalka
Aprendiz
Registrado: Domingo, 16 de Julho de 2006
Mensagens: 157
|
 Enviada: Qua Nov 04, 2015 9:17 pm Assunto: Ajuda com função fonética |
 |
|
Boa noite.
Alguém poderia me ajudar com uma função fonética /?
falta a parte que apague a ultima letra de um nome de acordo com as condições impostas
Exemplo:
Eliminar as terminações S, Z, R, R, M, N, AO e L;
nome para exemplo:
* Manoel José da Silva Santos.
Apos passar na funçao ficaria:
Manoe Jose Silva Santo
To tentando implementar a funçao de fonética da BuscaBR e esta faltando esta parte.
Caso alguem possua mais alguma ideia para melhorar a função ou diminuir o codigo será bem vinda!
Segue as regras da função:
. Converter todas as letras para Maiúsculo;
2. Eliminar todos os acentos;
3. Substituir Y por I;
4. Substituir BR por B;
5. Substituir PH por F;
6. Substituir GR, MG, NG, RG por G;
7. Substituir GE, GI, RJ, MJ, NJ por J;
8. Substituir Q, CA, CO, CU, C por K;
9. Substituir LH por L;
10. Substituir N, RM, GM, MD, SM e Terminação AO por M;
11. Substituir NH por N;
12. Substituir PR por P;
13. Substituir Ç, X, TS, C, Z, RS por S;
14. Substituir LT, TR, CT, por T;
15. Substituir W por V;
16. Eliminar as terminações S, Z, R, R, M, N, AO e L;
17. Substituir R por L;
18. Eliminar todas as vogais e o H;
19. Eliminar todas as letras em duplicidade;
| Código: | Function SOUNDEX_BUSCA_BR_ADAPTADO(N: string): string;
var
LP: TStringList; // declaração de lista de string ou stringlist
i: integer; // declaraçao de valor inteiro
S: string; // declaração de variavel string auxiliar
Begin
// A string N será repassada no momento da solicitação da função...
if trim(N) = '' then // se a string for igual a vazio para o processo !!!
begin
exit;
end;
LP := TStringList.Create; // cria uma stringlist…
try
S := AnsiUpperCase(N); // todas as letras maiúsculas e armazena na string s
for i := 1 to length(S) do
if S[i] in ['Á', 'Ã', 'À', 'Â', 'Ä'] then // retira todos os acentos da vogal “A”
S := copy(S, 1, i - 1) + 'A' + copy(S, i + 1, 255)
Else
if S[i] in ['É', 'È', 'Ê', 'Ë'] then // retira todos os acentos da vogal “E”
S := copy(S, 1, i - 1) + 'E' + copy(S, i + 1, 255)
Else
if S[i] in ['Í', 'Ì', 'Î', 'Ï'] then // retira todos os acentos da vogal “I”
S := copy(S, 1, i - 1) + 'I' + copy(S, i + 1, 255)
Else
if S[i] in ['Ó', 'Õ', 'Ò', 'Ô', 'Ö'] then // retira todos os acentos da vogal “O”
S := copy(S, 1, i - 1) + 'O' + copy(S, i + 1, 255)
Else
if S[i] in ['Ú', 'Ù', 'Û', 'Ü'] then // retira todos os acentos da vogal “U”
S := copy(S, 1, i - 1) + 'U' + copy(S, i + 1, 255)
Else
if S[i] in ['Ñ'] then // retira todos os acentos da consoante “N”
S := copy(S, 1, i - 1) + 'N' + copy(S, i + 1, 255)
Else
if S[i] in ['Ç'] then // TRANSFORMA cedilha EM C
S := copy(S, 1, i - 1) + 'C' + copy(S, i + 1, 255)
Else
if S[i] in ['.'] then // RETIRA O PONTO
S := copy(S, 1, i - 1) + ' ' + copy(S, i + 1, 255)
Else
if S[i] in ['-'] then // RETIRA O HIFEN
S := copy(S, 1, i - 1) + ' ' + copy(S, i + 1, 255)
Else
if S[i] in [''''] then // RETIRA ASPAS DUPLAS
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in [';'] then // RETIRA PONTO E VIRGULA
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in [','] then // RETIRA VIRGULA
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in [':'] then // RETIRA DOIS PONTOS
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['0'] then // RETIRA numero zero
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['1'] then // RETIRA numero um
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['2'] then // RETIRA numero dois
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['3'] then // RETIRA numero tres
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['4'] then // RETIRA numero quatro
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['5'] then // RETIRA numero cinco
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['6'] then // RETIRA numero seis
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['7'] then // RETIRA numero sete
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['8'] then // RETIRA numero oito
S := copy(S, 1, i - 1) + copy(S, i + 1, 255)
Else
if S[i] in ['9'] then // RETIRA numero nove
S := copy(S, 1, i - 1) + copy(S, i + 1, 255);
LP := SplitWord(S, ' ?');
if length(LP[0]) >= 1 then
begin
for i := LP.Count - 1 downto 0 do
if length(LP[i]) = 1 then
LP.Delete(i);
if LP.Count >= 1 then // RETIRA PREPOSIÇÕES
begin
for i := LP.Count - 1 downto 0 do
if (LP[i] = 'DA') or
(LP[i] = 'DE') or
(LP[i] = 'DI') or
(LP[i] = 'DO') or
(LP[i] = 'DU') or
(LP[i] = 'DR') or
(LP[i] = 'DAS') or
(LP[i] = 'DOS') or
(LP[i] = 'DAL') or
(LP[i] = 'DEL') or
(LP[i] = 'DER') or
(LP[i] = 'LA') or
(LP[i] = 'LE') or
(LP[i] = 'LO') or
(LP[i] = 'LAS') or
(LP[i] = 'LES') or
(LP[i] = 'LOS') or
(LP[i] = 'VAN') or
(LP[i] = 'VON') or
(LP[i] = 'EL') then
LP.Delete(i);
end;
if LP.Count >= 1 then // RETIRA TITULOS
begin
if (LP[0] = 'CAP') or
(LP[0] = 'CAPITAO') or
(LP[0] = 'CEL') or
(LP[0] = 'CORONEL') or
(LP[0] = 'GAL') or
(LP[0] = 'GEN') or
(LP[0] = 'GENERAL') or
(LP[0] = 'MAJ') or
(LP[0] = 'MAJOR') or
(LP[0] = 'SARG') or
(LP[0] = 'SARGENTO') or
(LP[0] = 'TEN') or
(LP[0] = 'TENENTE') or
(LP[0] = 'BEL') or
(LP[0] = 'BACHAR') or
(LP[0] = 'BACHAREL') or
(LP[0] = 'DR') or
(LP[0] = 'DOUTOR') or
(LP[0] = 'DRA') or
(LP[0] = 'DOUTORA') or
(LP[0] = 'ENG') or
(LP[0] = 'ENGENHEIRO') or
(LP[0] = 'ENGENHEIRA') or
(LP[0] = 'MED') or
(LP[0] = 'MEDICO') or
(LP[0] = 'PROF') or
(LP[0] = 'PROFESSOR') or
(LP[0] = 'PE') or
(LP[0] = 'PADRE') or
(LP[0] = 'VIUVA') or
(LP[0] = 'VVA') then
if LP.Count >= 3 then
LP.Delete(0);
end;
if LP.Count >= 1 then // RETIRADA DE PALAVRAS QUE ASSOCIAM AO NOME ERRONEAMENTE…
begin
if
// (LP[LP.Count-1] = 'FILHO') or //RETIRADA POR EXISTIR SOBRENOME
(LP[LP.Count - 1] = 'FILHA') or
(LP[LP.Count - 1] = 'FA') or
(LP[LP.Count - 1] = 'FO') or
(LP[LP.Count - 1] = 'FILHOS') or
(LP[LP.Count - 1] = 'FILHAS') or
// (LP[LP.Count-1] = 'NETO') or //RETIRADA POR EXISTIR SOBRENOME
// (LP[LP.Count-1] = 'NETA') or //RETIRADA POR EXISTIR SOBRENOME
(LP[LP.Count - 1] = 'NETTO') or
(LP[LP.Count - 1] = 'NETTA') or
(LP[LP.Count - 1] = 'BISNETO') or
(LP[LP.Count - 1] = 'BISNETA') or
(LP[LP.Count - 1] = 'BISNETTO') or
(LP[LP.Count - 1] = 'BISNETTA') or
(LP[LP.Count - 1] = 'BISNET') or
(LP[LP.Count - 1] = 'PRIMO') or
(LP[LP.Count - 1] = 'PRIMA') or
(LP[LP.Count - 1] = 'SOB') or
(LP[LP.Count - 1] = 'SOBRIN') or
(LP[LP.Count - 1] = 'SOBRINHO') or
(LP[LP.Count - 1] = 'SOBRINHA') or
(LP[LP.Count - 1] = 'IRMAO') or
(LP[LP.Count - 1] = 'IRMAOS') or
(LP[LP.Count - 1] = 'SEGUND') or
(LP[LP.Count - 1] = 'SEGUNDO') or
(LP[LP.Count - 1] = 'TERCEIRO') or
(LP[LP.Count - 1] = 'TERCEIRA') or
(LP[LP.Count - 1] = 'JUNIOR') or
(LP[LP.Count - 1] = 'JR') then
if LP.Count >= 3 then
LP.Delete(LP.Count - 1);
end;
S := ''; // LIMPA A VARIAVEL COM A STRING FINAL…
for i := 0 to LP.Count - 1 do
if S = '' then
S := LP[i]
else
S := S + ' ' + LP[i];
// armazena a string principal “S” com o valor final depois de tratada…
// INICIA A FASE FINAL DA CODIFICAÇAO FONÉTICA...
// INICIO DO SOUNDEX_BUSCA_BR_ADAPTADO_JJMALKA
// COMO RETORNA ACIMA A STRING “S” TRATO DA MESMA FORMA DO INICIO DA ANALISE...CONTO QUANTOS CARACTERES SOBRARAM E RODO O SOUNDEX NO RESTANTE DA STRING...
for i := 1 to length(S) do
if S[i] in ['AO'] then // substitui o “AO” pela “M”
S := copy(S, 1, i - 1) + 'M' + copy(S, i + 1, 255)
Else
if S[i] in ['BR'] then // substitui o “BR” pela “B”
S := copy(S, 1, i - 1) + 'B' + copy(S, i + 1, 255)
Else
if S[i] in ['C'] then // substitui o “C” pela “S”
S := copy(S, 1, i - 1) + 'S' + copy(S, i + 1, 255)
Else
if S[i] in ['CA'] then // substitui o “CA” pela “K”
S := copy(S, 1, i - 1) + 'K' + copy(S, i + 1, 255)
Else
if S[i] in ['CO'] then // substitui o “CO” pela “K”
S := copy(S, 1, i - 1) + 'K' + copy(S, i + 1, 255)
Else
if S[i] in ['CU'] then // substitui o “CU” pela “K”
S := copy(S, 1, i - 1) + 'K' + copy(S, i + 1, 255)
Else // NAO TEM Ç POIS MUDA ANTERIORMENTE PARA C.
if S[i] in ['CH'] then // substitui o “CH” pela “S”
S := copy(S, 1, i - 1) + 'S' + copy(S, i + 1, 255)
Else
if S[i] in ['CT'] then // substitui o “CT” pela “T”
S := copy(S, 1, i - 1) + 'T' + copy(S, i + 1, 255)
Else
if S[i] in ['GE'] then // substitui o “GE” pela “J”
S := copy(S, 1, i - 1) + 'J' + copy(S, i + 1, 255)
Else
if S[i] in ['GI'] then // substitui o “GI” pela “J”
S := copy(S, 1, i - 1) + 'J' + copy(S, i + 1, 255)
Else
if S[i] in [‘ GM ’] then // substitui o “GM” pela “M”
S := copy(S, 1, i - 1) + 'M' + copy(S, i + 1, 255)
Else
if S[i] in ['GR'] then // substitui o “GR” pela “G”
S := copy(S, 1, i - 1) + 'G' + copy(S, i + 1, 255)
Else
if S[i] in ['LH'] then // substitui o “LH” pela “L”
S := copy(S, 1, i - 1) + 'L' + copy(S, i + 1, 255)
Else
if S[i] in ['LT'] then // substitui o “LT” pela “T”
S := copy(S, 1, i - 1) + 'T' + copy(S, i + 1, 255)
Else
if S[i] in ['MD'] then // substitui o “MD” pela “M”
S := copy(S, 1, i - 1) + 'M' + copy(S, i + 1, 255)
Else
if S[i] in ['MG'] then // substitui o “MG” pela “G”
S := copy(S, 1, i - 1) + 'G' + copy(S, i + 1, 255)
Else
if S[i] in ['MJ'] then // substitui o “MJ” pela “J”
S := copy(S, 1, i - 1) + 'J' + copy(S, i + 1, 255)
Else
if S[i] in ['N'] then // substitui o “N” pela “M”
S := copy(S, 1, i - 1) + 'M' + copy(S, i + 1, 255)
Else
if S[i] in ['NG'] then // substitui o “NG” pela “G”
S := copy(S, 1, i - 1) + 'G' + copy(S, i + 1, 255)
Else
if S[i] in ['NH'] then // substitui o “NH” pela “N”
S := copy(S, 1, i - 1) + 'N' + copy(S, i + 1, 255)
Else
if S[i] in ['NJ'] then // substitui o “NJ” pela “J”
S := copy(S, 1, i - 1) + 'J' + copy(S, i + 1, 255)
Else
if S[i] in ['PH'] then // substitui o “PH” pela “F”
S := copy(S, 1, i - 1) + 'F' + copy(S, i + 1, 255)
Else
if S[i] in ['PR'] then // substitui o “PR” pela “P”
S := copy(S, 1, i - 1) + 'P' + copy(S, i + 1, 255)
Else
if S[i] in ['Q'] then // substitui o “Q” pela “K”
S := copy(S, 1, i - 1) + 'K' + copy(S, i + 1, 255)
Else
if S[i] in ['RG'] then // substitui o “RG” pela “G”
S := copy(S, 1, i - 1) + 'G' + copy(S, i + 1, 255)
Else
if S[i] in ['RS'] then // substitui o “RS” pela vogal “S”
S := copy(S, 1, i - 1) + 'S' + copy(S, i + 1, 255)
Else
if S[i] in ['RM'] then // substitui o “RM” pela “M”
S := copy(S, 1, i - 1) + 'M' + copy(S, i + 1, 255)
Else
if S[i] in ['RJ'] then // substitui o “RJ” pela “J”
S := copy(S, 1, i - 1) + 'J' + copy(S, i + 1, 255)
Else
if S[i] in ['SM'] then // substitui o “SM” pela “M”
S := copy(S, 1, i - 1) + 'M' + copy(S, i + 1, 255)
Else
if S[i] in ['TR'] then // substitui o “TR” pela “T”
S := copy(S, 1, i - 1) + 'T' + copy(S, i + 1, 255)
Else
if S[i] in ['TS'] then // substitui o “TS” pela “S”
S := copy(S, 1, i - 1) + 'S' + copy(S, i + 1, 255)
Else
if S[i] in ['W'] then // substitui o “W” pela “V”
S := copy(S, 1, i - 1) + 'V' + copy(S, i + 1, 255)
Else
if S[i] in ['X'] then // substitui o “X” pela “S”
S := copy(S, 1, i - 1) + 'S' + copy(S, i + 1, 255)
Else
if S[i] in ['Y'] then // substitui o “Y” pela “I”
S := copy(S, 1, i - 1) + 'I' + copy(S, i + 1, 255)
Else
if S[i] in ['Z'] then // substitui o “Z” pela “S”
S := copy(S, 1, i - 1) + 'S' + copy(S, i + 1, 255)
// BLOCO FINAL DO SOUNDEX…
// Eliminar as terminações S, Z, R, R, M, N, AO e L;
{
Bloco com função para apagar ultima letra no nome...
}
// FALTA VER ESTA FUNÇAO: APAGAR ULTIMO CARACTER
// INICIO DA RETIRADA DE LETRAS DUPLICADAS…
if S[i] in ['AA'] then // substitui o “AA” pela “A”
S := copy(S, 1, i - 1) + 'B' + copy(S, i + 1, 255)
Else
if S[i] in ['BB'] then // substitui o “BB” pela “B”
S := copy(S, 1, i - 1) + 'B' + copy(S, i + 1, 255)
Else
if S[i] in ['CC'] then // substitui o “CC” pela “C”
S := copy(S, 1, i - 1) + 'C' + copy(S, i + 1, 255)
Else
if S[i] in ['DD'] then // substitui o “DD” pela “D”
S := copy(S, 1, i - 1) + 'D' + copy(S, i + 1, 255)
Else
if S[i] in ['EE'] then // substitui o “EE” pela “E”
S := copy(S, 1, i - 1) + 'E' + copy(S, i + 1, 255)
Else
if S[i] in ['FF'] then // substitui o “FF” pela “F”
S := copy(S, 1, i - 1) + 'F' + copy(S, i + 1, 255)
Else
if S[i] in ['GG'] then // substitui o “GG” pela “G”
S := copy(S, 1, i - 1) + 'G' + copy(S, i + 1, 255)
Else
if S[i] in ['HH'] then // substitui o “HH” pela “H”
S := copy(S, 1, i - 1) + 'H' + copy(S, i + 1, 255)
Else
if S[i] in ['II'] then // substitui o “II” pela “I”
S := copy(S, 1, i - 1) + 'I' + copy(S, i + 1, 255)
Else
if S[i] in ['JJ'] then // substitui o “JJ” pela “J”
S := copy(S, 1, i - 1) + 'J' + copy(S, i + 1, 255)
Else
if S[i] in ['KK'] then // substitui o “KK” pela “K”
S := copy(S, 1, i - 1) + 'K' + copy(S, i + 1, 255)
Else
if S[i] in ['LL'] then // substitui o “LL” pela “L”
S := copy(S, 1, i - 1) + 'L' + copy(S, i + 1, 255)
Else
if S[i] in ['MM'] then // substitui o “MM” pela “M”
S := copy(S, 1, i - 1) + 'M' + copy(S, i + 1, 255)
Else
if S[i] in ['NN'] then // substitui o “NN” pela “N”
S := copy(S, 1, i - 1) + 'N' + copy(S, i + 1, 255)
Else
if S[i] in ['OO'] then // substitui o “OO” pela “O”
S := copy(S, 1, i - 1) + 'O' + copy(S, i + 1, 255)
Else
if S[i] in ['PP'] then // substitui o “PP” pela “P”
S := copy(S, 1, i - 1) + 'P' + copy(S, i + 1, 255)
Else
if S[i] in ['QQ'] then // substitui o “QQ” pela “Q”
S := copy(S, 1, i - 1) + 'Q' + copy(S, i + 1, 255)
Else
if S[i] in ['RR'] then // substitui o “RR” pela “R”
S := copy(S, 1, i - 1) + 'R' + copy(S, i + 1, 255)
Else
if S[i] in ['SS'] then // substitui o “SS” pela “S”
S := copy(S, 1, i - 1) + 'S' + copy(S, i + 1, 255)
Else
if S[i] in ['TT'] then // substitui o “TT” pela “T”
S := copy(S, 1, i - 1) + 'T' + copy(S, i + 1, 255)
Else
if S[i] in ['UU'] then // substitui o “UU” pela “U”
S := copy(S, 1, i - 1) + 'U' + copy(S, i + 1, 255)
Else
if S[i] in ['VV'] then // substitui o “VV” pela “V”
S := copy(S, 1, i - 1) + 'V' + copy(S, i + 1, 255)
Else
if S[i] in ['WW'] then // substitui o “WW” pela “W”
S := copy(S, 1, i - 1) + 'W' + copy(S, i + 1, 255)
Else
if S[i] in ['XX'] then // substitui o “XX” pela “X”
S := copy(S, 1, i - 1) + 'X' + copy(S, i + 1, 255)
Else
if S[i] in ['YY'] then // substitui o “YY” pela “Y”
S := copy(S, 1, i - 1) + 'Y' + copy(S, i + 1, 255)
Else
if S[i] in ['ZZ'] then // substitui o “ZZ” pela “Z”
S := copy(S, 1, i - 1) + 'Z' + copy(S, i + 1, 255)
// FINAL DE ANALISE DE CARACTERES DUPLICADOS…
// Eliminar todas as vogais restantes e mais o H
Else
if S[i] in ['A'] then // Apaga A
S := copy(S, 1, i - 1) + '' + copy(S, i + 1, 255)
Else
if S[i] in ['E'] then // Apaga E
S := copy(S, 1, i - 1) + '' + copy(S, i + 1, 255)
Else
if S[i] in ['I'] then // Apaga I
S := copy(S, 1, i - 1) + '' + copy(S, i + 1, 255)
Else
if S[i] in ['O'] then // Apaga O
S := copy(S, 1, i - 1) + '' + copy(S, i + 1, 255)
Else
if S[i] in ['U'] then // Apaga U
S := copy(S, 1, i - 1) + '' + copy(S, i + 1, 255)
// MAIS A CONSOANTE “H”
Else
if S[i] in ['H'] then // Apaga H
S := copy(S, 1, i - 1) + '' + copy(S, i + 1, 255);
// FINAL DA ANALISE FONÉTICA…
end;
finally
LP.Free;
end;
Result := S;
end; |
|
|
| Voltar ao Topo |
|
 |
strak2012
Colaborador
Registrado: Segunda-Feira, 13 de Janeiro de 2014
Mensagens: 1518
Localização: Maceió - AL
|
| Enviada: Qui Nov 05, 2015 1:38 am Assunto: |
|
|
| Código: | Function SOUNDEX_BUSCA_BR_ADAPTADO(N: string): string;
const
REGRA: array [1 .. 36,1 .. 2] of string = (
{01º}('Y','I'),
{02º}('BR','B'),
{03º}('PH','F'),
{04º}('GR','G'), ('MG','G'), ('NG','G'), ('RG','G'),
{05º}('GE','J'), ('GI','J'), ('RJ','J'), ('MJ','J'), ('NJ', 'J'),
{06º}('Q' ,'K'), ('CA','K'), ('CO','K'), ('CU','K'), ('C','K'),
{07º}('LH','L'),
{08º}('N','M'), ('RM','M'), ('GM','M'), ('MD','M'),('SM','M'), ('AO','M'),
{09º}('NH','N'),
{10º}('PR','P'),
{11º}('Ç','S'), ('X','S'), ('TS','S'), ('C','S'), ('Z','S'), ('RS','S'),
{12º}('LT','T'),('TR','T'),('CT','T'),
{13º}('W','V'));
PREPOSICOES:array[1..20] of string=(
'DA' , 'DE' , 'DI' , 'DO' , 'DU' , 'DR' , 'DAS', 'DOS',
'DAL', 'DEL', 'DER', 'LA' , 'LE' , 'LO' , 'LAS', 'LES',
'LOS', 'VAN', 'VON', 'EL');
TITULOS:array[1..31] of string=(
'CAP' , 'CAPITAO' , 'CEL' , 'CORONEL' ,
'GAL' , 'GEN' , 'GENERAL' , 'MAJ' ,
'MAJOR' , 'SARG' , 'SARGENTO' , 'TEN' ,
'TENENTE' , 'BEL' , 'BACHAR' , 'BACHAREL',
'DR' , 'DOUTOR' , 'DRA' , 'DOUTORA' ,
'ENG' , 'ENGENHEIRO', 'ENGENHEIRA', 'MED' ,
'MEDICO' , 'PROF' , 'PROFESSOR' , 'PE' ,
'PADRE' , 'VIUVA' , 'VVA' );
SOBRENOMES:array[1..26] of string=(
'FILHA' , 'FA' , 'FO' , 'FILHOS' , 'FILHAS' ,
'NETTO' , 'NETTA' , 'BISNETO' , 'BISNETA' , 'BISNETTO',
'BISNETTA', 'BISNET' , 'PRIMO' , 'PRIMA' , 'SOB' ,
'SOBRIN' , 'SOBRINHO', 'SOBRINHA', 'IRMAO' , 'IRMAOS' ,
'SEGUND' , 'SEGUNDO' , 'TERCEIRO', 'TERCEIRA', 'JUNIOR' ,
'JR');
TERMINACOES:array[1..7] of string=(
'S', 'Z', 'R', 'M', 'N', 'AO', 'L');
var
i: integer; // declaraçao de valor inteiro
Begin
// A string N será repassada no momento da solicitação da função...
if trim(N) = '' then // se a string for igual a vazio para o processo !!!
exit;
// todas as letras maiúsculas
N := ' '+AnsiUpperCase(N)+' ';
for i := 1 to length(N) do
begin
// retira todos os acentos da vogal “A”
if N[i] in ['Á', 'Ã', 'À', 'Â', 'Ä'] then N[i] := 'A';
// retira todos os acentos da vogal “E”
if N[i] in ['É', 'È', 'Ê', 'Ë'] then N[i] := 'E';
// retira todos os acentos da vogal “I”
if N[i] in ['Í', 'Ì', 'Î', 'Ï'] then N[i] := 'I';
// retira todos os acentos da vogal “O”
if N[i] in ['Ó', 'Õ', 'Ò', 'Ô', 'Ö'] then N[i] := 'O';
// retira todos os acentos da vogal “U”
if N[i] in ['Ú', 'Ù', 'Û', 'Ü'] then N[i] := 'U';
// retira todos os acentos da consoante “N”
if N[i] = 'Ñ' then N[i] := 'N';
// TRANSFORMA cedilha EM C
if N[i] = 'Ç' then N[i] := 'C';
// retira caracteres que não pertença ao conjunto 'A'..'Z' e ' '
if not(N[i] in ['A' .. 'Z', ' ']) then delete(N, i, 1);
end;
// RETIRA PREPOSIÇÕES
for i := Low(PREPOSICOES) to High(PREPOSICOES) do
N:=StringReplace(N,' '+PREPOSICOES[i]+' ',' ',[rfReplaceAll]);
// RETIRA TITULOS
for i := Low(TITULOS) to High(TITULOS) do
N:=StringReplace(N,' '+TITULOS[i]+' ',' ',[rfReplaceAll]);
// RETIRADA DE PALAVRAS QUE ASSOCIAM AO NOME ERRONEAMENTE…
for i := Low(SOBRENOMES) to High(SOBRENOMES) do
N:=StringReplace(N,' '+SOBRENOMES[i]+' ',' ',[rfReplaceAll]);
// *** INICIA A FASE FINAL DA CODIFICAÇAO FONÉTICA...
// *** INICIO DO SOUNDEX_BUSCA_BR_ADAPTADO_JJMALKA
// *** COMO RETORNA ACIMA A STRING “S” TRATO DA MESMA FORMA DO INICIO
// *** DA ANALISE...CONTO QUANTOS CARACTERES SOBRARAM E RODO O
// *** SOUNDEX NO RESTANTE DA STRING...
for i := Low(REGRA) to High(REGRA) do
N:=StringReplace(N,REGRA[i,1],REGRA[i,2],[rfReplaceAll]);
// ********** BLOCO FINAL DO SOUNDEX… ************
// Eliminar as terminações S, Z, R, R, M, N, AO e L;
for i := Low(TERMINACOES) to High(TERMINACOES) do
N:=StringReplace(N,TERMINACOES[i]+' ',' ',[rfReplaceAll]);
// INICIO DA RETIRADA DE LETRAS DUPLICADAS…
for I := ord('A') to ord('Z') do
N:=StringReplace(N,chr(i)+chr(i),chr(i),[rfReplaceAll]);
// FINAL DE ANALISE DE CARACTERES DUPLICADOS…
// Eliminar todas as vogais restantes e mais o H
//N:=StringReplace(N,'A','',[rfReplaceAll]);
//N:=StringReplace(N,'E','',[rfReplaceAll]);
//N:=StringReplace(N,'I','',[rfReplaceAll]);
//N:=StringReplace(N,'O','',[rfReplaceAll]);
//N:=StringReplace(N,'U','',[rfReplaceAll]);
// MAIS A CONSOANTE “H”
N:=StringReplace(N,'H','',[rfReplaceAll]);
// *** FINAL DA ANALISE FONÉTICA…
Result := trim(N);
end; |
falta alguma logica ai nesta interpretação das regras
no final ele pede para deletar todas as vogais e o H.
como assim?
explica e como
| Código: | | Manoel José da Silva Santos. |
passa a ser
| Código: | | Manoe Jose Silva Santo |
sem uso de vogais.
Uma outra falta é que em algum momento das regras ele pede para trocar N por M logo o nome Manoel passaria a ser Mamoe
de qualquer forma deixei de forma comentada a questão da vogais e deixei o codigo de facil alteração e ajuste futura caso nescessite.
_________________
Tudo podemos quando tudo sabemos! |
|
| Voltar ao Topo |
|
|
conorte
Experiente
Registrado: Quinta-Feira, 8 de Mai de 2014
Mensagens: 406
Localização: Porto Alegre/RS
|
| Enviada: Qui Nov 05, 2015 7:38 am Assunto: |
|
|
Olá!
Eu também fiquei com dúvida sobre tirar o "L" de Manoel e "S" de Santos. E também fiquei com dúvida em outras substituições que "desfigurariam" a palavra deixando-a "irreconhecível".
_________________
Luciano Moraes
1º curso de Pascal em 1998. |
|
| Voltar ao Topo |
|
|
jjmalka
Aprendiz
Registrado: Domingo, 16 de Julho de 2006
Mensagens: 157
|
| Enviada: Qui Nov 05, 2015 9:34 pm Assunto: |
|
|
| strak2012 escreveu: | | Código: | Function SOUNDEX_BUSCA_BR_ADAPTADO(N: string): string;
const
REGRA: array [1 .. 36,1 .. 2] of string = (
{01º}('Y','I'),
{02º}('BR','B'),
{03º}('PH','F'),
{04º}('GR','G'), ('MG','G'), ('NG','G'), ('RG','G'),
{05º}('GE','J'), ('GI','J'), ('RJ','J'), ('MJ','J'), ('NJ', 'J'),
{06º}('Q' ,'K'), ('CA','K'), ('CO','K'), ('CU','K'), ('C','K'),
{07º}('LH','L'),
{08º}('N','M'), ('RM','M'), ('GM','M'), ('MD','M'),('SM','M'), ('AO','M'),
{09º}('NH','N'),
{10º}('PR','P'),
{11º}('Ç','S'), ('X','S'), ('TS','S'), ('C','S'), ('Z','S'), ('RS','S'),
{12º}('LT','T'),('TR','T'),('CT','T'),
{13º}('W','V'));
PREPOSICOES:array[1..20] of string=(
'DA' , 'DE' , 'DI' , 'DO' , 'DU' , 'DR' , 'DAS', 'DOS',
'DAL', 'DEL', 'DER', 'LA' , 'LE' , 'LO' , 'LAS', 'LES',
'LOS', 'VAN', 'VON', 'EL');
TITULOS:array[1..31] of string=(
'CAP' , 'CAPITAO' , 'CEL' , 'CORONEL' ,
'GAL' , 'GEN' , 'GENERAL' , 'MAJ' ,
'MAJOR' , 'SARG' , 'SARGENTO' , 'TEN' ,
'TENENTE' , 'BEL' , 'BACHAR' , 'BACHAREL',
'DR' , 'DOUTOR' , 'DRA' , 'DOUTORA' ,
'ENG' , 'ENGENHEIRO', 'ENGENHEIRA', 'MED' ,
'MEDICO' , 'PROF' , 'PROFESSOR' , 'PE' ,
'PADRE' , 'VIUVA' , 'VVA' );
SOBRENOMES:array[1..26] of string=(
'FILHA' , 'FA' , 'FO' , 'FILHOS' , 'FILHAS' ,
'NETTO' , 'NETTA' , 'BISNETO' , 'BISNETA' , 'BISNETTO',
'BISNETTA', 'BISNET' , 'PRIMO' , 'PRIMA' , 'SOB' ,
'SOBRIN' , 'SOBRINHO', 'SOBRINHA', 'IRMAO' , 'IRMAOS' ,
'SEGUND' , 'SEGUNDO' , 'TERCEIRO', 'TERCEIRA', 'JUNIOR' ,
'JR');
TERMINACOES:array[1..7] of string=(
'S', 'Z', 'R', 'M', 'N', 'AO', 'L');
var
i: integer; // declaraçao de valor inteiro
Begin
// A string N será repassada no momento da solicitação da função...
if trim(N) = '' then // se a string for igual a vazio para o processo !!!
exit;
// todas as letras maiúsculas
N := ' '+AnsiUpperCase(N)+' ';
for i := 1 to length(N) do
begin
// retira todos os acentos da vogal “A”
if N[i] in ['Á', 'Ã', 'À', 'Â', 'Ä'] then N[i] := 'A';
// retira todos os acentos da vogal “E”
if N[i] in ['É', 'È', 'Ê', 'Ë'] then N[i] := 'E';
// retira todos os acentos da vogal “I”
if N[i] in ['Í', 'Ì', 'Î', 'Ï'] then N[i] := 'I';
// retira todos os acentos da vogal “O”
if N[i] in ['Ó', 'Õ', 'Ò', 'Ô', 'Ö'] then N[i] := 'O';
// retira todos os acentos da vogal “U”
if N[i] in ['Ú', 'Ù', 'Û', 'Ü'] then N[i] := 'U';
// retira todos os acentos da consoante “N”
if N[i] = 'Ñ' then N[i] := 'N';
// TRANSFORMA cedilha EM C
if N[i] = 'Ç' then N[i] := 'C';
// retira caracteres que não pertença ao conjunto 'A'..'Z' e ' '
if not(N[i] in ['A' .. 'Z', ' ']) then delete(N, i, 1);
end;
// RETIRA PREPOSIÇÕES
for i := Low(PREPOSICOES) to High(PREPOSICOES) do
N:=StringReplace(N,' '+PREPOSICOES[i]+' ',' ',[rfReplaceAll]);
// RETIRA TITULOS
for i := Low(TITULOS) to High(TITULOS) do
N:=StringReplace(N,' '+TITULOS[i]+' ',' ',[rfReplaceAll]);
// RETIRADA DE PALAVRAS QUE ASSOCIAM AO NOME ERRONEAMENTE…
for i := Low(SOBRENOMES) to High(SOBRENOMES) do
N:=StringReplace(N,' '+SOBRENOMES[i]+' ',' ',[rfReplaceAll]);
// *** INICIA A FASE FINAL DA CODIFICAÇAO FONÉTICA...
// *** INICIO DO SOUNDEX_BUSCA_BR_ADAPTADO_JJMALKA
// *** COMO RETORNA ACIMA A STRING “S” TRATO DA MESMA FORMA DO INICIO
// *** DA ANALISE...CONTO QUANTOS CARACTERES SOBRARAM E RODO O
// *** SOUNDEX NO RESTANTE DA STRING...
for i := Low(REGRA) to High(REGRA) do
N:=StringReplace(N,REGRA[i,1],REGRA[i,2],[rfReplaceAll]);
// ********** BLOCO FINAL DO SOUNDEX… ************
// Eliminar as terminações S, Z, R, R, M, N, AO e L;
for i := Low(TERMINACOES) to High(TERMINACOES) do
N:=StringReplace(N,TERMINACOES[i]+' ',' ',[rfReplaceAll]);
// INICIO DA RETIRADA DE LETRAS DUPLICADAS…
for I := ord('A') to ord('Z') do
N:=StringReplace(N,chr(i)+chr(i),chr(i),[rfReplaceAll]);
// FINAL DE ANALISE DE CARACTERES DUPLICADOS…
// Eliminar todas as vogais restantes e mais o H
//N:=StringReplace(N,'A','',[rfReplaceAll]);
//N:=StringReplace(N,'E','',[rfReplaceAll]);
//N:=StringReplace(N,'I','',[rfReplaceAll]);
//N:=StringReplace(N,'O','',[rfReplaceAll]);
//N:=StringReplace(N,'U','',[rfReplaceAll]);
// MAIS A CONSOANTE “H”
N:=StringReplace(N,'H','',[rfReplaceAll]);
// *** FINAL DA ANALISE FONÉTICA…
Result := trim(N);
end; |
falta alguma logica ai nesta interpretação das regras
no final ele pede para deletar todas as vogais e o H.
como assim?
explica e como
| Código: | | Manoel José da Silva Santos. |
passa a ser
| Código: | | Manoe Jose Silva Santo |
sem uso de vogais.
Uma outra falta é que em algum momento das regras ele pede para trocar N por M logo o nome Manoel passaria a ser Mamoe
de qualquer forma deixei de forma comentada a questão da vogais e deixei o codigo de facil alteração e ajuste futura caso nescessite. |
Boa noite Strak2012
o que realmente estava precisando foi como o inicio da mensagem:
Alguém poderia me ajudar com uma função fonética /?
falta a parte que apague a ultima letra de um nome de acordo com as condições impostas
Exemplo:
Eliminar as terminações S, Z, R, R, M, N, AO e L;
nome para exemplo:
* Manoel José da Silva Santos.
Apos passar na funçao ficaria:
Manoe Jose Silva Santo
O que eu nao estava conseguindo era apagar a ultima letra de um nome, o exemplo era apenas para as terminações acima citadas.
O que voces talvez nao entenderam era justamente que a função estava praticamente pronta mas faltava isto. Postei ela por inteiro para ajudar outras pessoas que necessitem.
Caso fosse passa toda a função no nome do exemplo eu teria uma codificação totalmente diferente. |
|
| Voltar ao Topo |
|
|
jjmalka
Aprendiz
Registrado: Domingo, 16 de Julho de 2006
Mensagens: 157
|
| Enviada: Qui Nov 05, 2015 9:39 pm Assunto: |
|
|
| conorte escreveu: | Olá!
Eu também fiquei com dúvida sobre tirar o "L" de Manoel e "S" de Santos. E também fiquei com dúvida em outras substituições que "desfigurariam" a palavra deixando-a "irreconhecível". |
Boa noite conorte.
O que acontece no meu caso para utilizar esta funçao é a forma com que pode ser utilizada a escrita de um determinado nome.
A fonética é um ponto complicado para determinados registros, como no meu: nome de pessoas.
O nome Heitor por exemplo, pode ser escrito:
Heitor
Eitor
Eytor
Eyto
...
tudo isto de acordo com o nivel do usuario que ficará responsavel pela inclusao dos dados.
E no finalmente como iria localizar esta pessoa?...
Dai a necessidade de uma codificação de acordo com a fonética. |
|
| Voltar ao Topo |
|
|
strak2012
Colaborador
Registrado: Segunda-Feira, 13 de Janeiro de 2014
Mensagens: 1518
Localização: Maceió - AL
|
| Enviada: Sex Nov 06, 2015 12:41 am Assunto: |
|
|
tente fazer uso da rotina:
| Código: | function ElimineTerminacoes(N: string; TERMINACOES: array of string): string;
procedure troque(var c1: char; c2: char; s: string);
var
r: char;
begin
r := c1;
if AnsiUpperCase(r) = c1 then
begin
if pos(c1, AnsiUpperCase(s)) <> 0 then
c1 := AnsiUpperCase(c2)[1];
end
else
begin
if pos(c1, AnsiLowerCase(s)) <> 0 then
c1 := AnsiLowerCase(c2)[1];
end;
end;
var
i: integer;
begin
N := ' ' + N + ' ';
for i := 1 to length(N) do
begin
troque(N[i], 'A', 'ÁÃÀÂÄ');
troque(N[i], 'E', 'ÉÈÊË');
troque(N[i], 'I', 'ÍÌÎÏ');
troque(N[i], 'O', 'ÓÕÒÔÖ');
troque(N[i], 'U', 'ÚÙÛÜ');
if N[i] = 'Ñ' then
N[i] := 'N';
if N[i] = 'Ç' then
N[i] := 'c';
if not(AnsiUpperCase(N[i])[1] in ['A' .. 'Z', ' ']) then
delete(N, i, 1);
end;
for i := Low(TERMINACOES) to High(TERMINACOES) do
N := StringReplace(N, AnsiUpperCase(TERMINACOES[i]) + ' ', ' ',
[rfIgnoreCase, rfReplaceAll]);
result := trim(N);
end;
|
da forma de uso
| Código: |
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := ElimineTerminacoes('Manoel José da Silva Santos',
['S', 'Z', 'R', 'M', 'N', 'AO', 'L']);
end; |
_________________
Tudo podemos quando tudo sabemos! |
|
| Voltar ao Topo |
|
|
jjmalka
Aprendiz
Registrado: Domingo, 16 de Julho de 2006
Mensagens: 157
|
| Enviada: Dom Nov 08, 2015 10:56 pm Assunto: |
|
|
| strak2012 escreveu: | tente fazer uso da rotina:
| Código: | function ElimineTerminacoes(N: string; TERMINACOES: array of string): string;
procedure troque(var c1: char; c2: char; s: string);
var
r: char;
begin
r := c1;
if AnsiUpperCase(r) = c1 then
begin
if pos(c1, AnsiUpperCase(s)) <> 0 then
c1 := AnsiUpperCase(c2)[1];
end
else
begin
if pos(c1, AnsiLowerCase(s)) <> 0 then
c1 := AnsiLowerCase(c2)[1];
end;
end;
var
i: integer;
begin
N := ' ' + N + ' ';
for i := 1 to length(N) do
begin
troque(N[i], 'A', 'ÁÃÀÂÄ');
troque(N[i], 'E', 'ÉÈÊË');
troque(N[i], 'I', 'ÍÌÎÏ');
troque(N[i], 'O', 'ÓÕÒÔÖ');
troque(N[i], 'U', 'ÚÙÛÜ');
if N[i] = 'Ñ' then
N[i] := 'N';
if N[i] = 'Ç' then
N[i] := 'c';
if not(AnsiUpperCase(N[i])[1] in ['A' .. 'Z', ' ']) then
delete(N, i, 1);
end;
for i := Low(TERMINACOES) to High(TERMINACOES) do
N := StringReplace(N, AnsiUpperCase(TERMINACOES[i]) + ' ', ' ',
[rfIgnoreCase, rfReplaceAll]);
result := trim(N);
end;
|
da forma de uso
| Código: |
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := ElimineTerminacoes('Manoel José da Silva Santos',
['S', 'Z', 'R', 'M', 'N', 'AO', 'L']);
end; |
|
Valeu strak2012. |
|
| Voltar ao Topo |
|
|
|
|
Enviar Mensagens Novas: Proibido.
Responder Tópicos Proibido
Editar Mensagens: Proibido.
Excluir Mensagens: Proibido.
Votar em Enquetes: Proibido.
|
|
FAQ
Pesquisar
Membros
Grupos
Registrar
Perfil
Entrar e ver Mensagens Particulares
Entrar
