Les petits papiers de SQLPro - L'art des Soundex - Club d'entraide des développeurs francophones

unit Sndx; //-------------------------------------------------------------------------- // Copyright : // Frédéric BROUARD pour Phonex - DROITS D'AUTEUR Réservé // Pour l'utiliser, contacter Frédéric BROUARD à l'e-mail : // brouardf@club-internet.fr // //-------------------------------------------------------------------------- interface // type de variable en retour de la fonction soundex Type Sound = string[4]; // déclaration des routines utilisées par les soundex Function prepare(sIn : string) : string; Function SearchReplace(sIn : string; mot1 : string; mot2 : string) : string; Function pow(x,y : integer) : double; // déclaration des fonctions de soundex Function soundex(sIn : string) : sound; Function soundex2(sIn : string) : sound; Function phonex(sIn : string) : double; implementation uses sysUtils ,dialogs ; //-------------------------------------------------------------------------- // fonction de recherche et remplacement de sous chaîne dans une chaîne //-------------------------------------------------------------------------- Function SearchReplace(sIn : string; mot1 : string; mot2 : string) : string; var tailleSin : integer; TailleMot : integer; posMot : integer; begin //effet de bord : le mot à remplacer est le même que le mot à chercher if mot1 = mot2 then begin result := sIn; exit; end; // effet de bord non géré : le mot à remplacer contient le mot à chercher // exemple : remplacer 'no' par 'not' tailleSin := length(Sin); TailleMot := length(mot1); posMot := pos(mot1,sIn); While posMot > 0 do begin // le mot à remplacer est en début de chaîne if posMot = 1 then sIn := mot2+copy(Sin,tailleMot+1,tailleSin-tailleMot) else // le mot à remplacer est en fin de chaîne if posMot + tailleMot -1 = tailleSin then sIn := copy(Sin,1,posMot-1)+mot2 // le mot à remplacer est au milieu else sIn := copy(Sin,1,posMot-1)+mot2 +copy(sin,posMot+tailleMot,tailleSin-(posMot+tailleMot-1)); posMot := pos(mot1,sIn); end; result := Sin; end; //-------------------------------------------------------------------------- // fonction de recherche et remplacement de sous chaîne dans une chaîne // sauf si la lettre suivante est une voyelle ou un son de 1 à 4 //-------------------------------------------------------------------------- Function SRSaufVoyelle (sIn : string; mot1 : string; mot2 : string) : string; const Voyelle = ['a','e','i','o','u','y','1','2','3','4']; var tailleSin : integer; TailleMot : integer; posMot : integer; derLet : char; begin //effet de bord : le mot à remplacer est le même que le mot à chercher if mot1 = mot2 then begin result := sIn; exit; end; // effet de bord non géré : le mot à remplacer contient le mot à chercher // exemple : remplacer 'no' par 'not' tailleSin := length(Sin); TailleMot := length(mot1); posMot := pos(mot1,sIn); While posMot > 0 do begin // la lettre suivante est-elle une voyelle ? if posMot+tailleMot-1 < tailleSin then begin derlet := sIn[posMot+tailleMot]; if derLet in voyelle then result := sIn; exit; end; // le mot à remplacer est en début de chaîne if posMot = 1 then sIn := mot2+copy(Sin,tailleMot+1,tailleSin-tailleMot) else // le mot à remplacer est en fin de chaîne if posMot + tailleMot -1 = tailleSin then sIn := copy(Sin,1,posMot-1)+mot2 // le mot à remplacer est au milieu else sIn := copy(Sin,1,posMot-1)+mot2 +copy(sin,posMot+tailleMot,tailleSin-(posMot+tailleMot-1)); posMot := pos(mot1,sIn); end; result := Sin; end; //-------------------------------------------------------------------------- // fonction de recherche et remplacement de sous chaîne dans une chaîne // sauf si la lettre suivante est une voyelle ou un son de 1 à 4 //-------------------------------------------------------------------------- Function SRSauf2Voyelle (sIn : string; mot1 : string; mot2 : string) : string; const Voyelle = ['a','e','i','o','u','y','1','2','3','4']; var tailleSin : integer; TailleMot : integer; posMot : integer; derLet : char; premlet : char; begin //effet de bord : le mot à remplacer est le même que le mot à chercher if mot1 = mot2 then begin result := sIn; exit; end; // effet de bord non géré : le mot à remplacer contient le mot à chercher // exemple : remplacer 'no' par 'not' tailleSin := length(Sin); TailleMot := length(mot1); posMot := pos(mot1,sIn); While posMot > 0 do begin // y a t-il une lettre précédente et une suivante ? if (posMot > 1) and (posMot+tailleMot-1 < tailleSin) then begin premLet := sIn[posMot-1]; derlet := sIn[posMot+tailleMot]; // ces lettres sont-elles des voyelles ? if not ((premLet in voyelle) and (derLet in voyelle)) then exit; end; // le mot à remplacer est en début de chaîne if posMot = 1 then sIn := mot2+copy(Sin,tailleMot+1,tailleSin-tailleMot) else // le mot à remplacer est en fin de chaîne if posMot + tailleMot -1 = tailleSin then sIn := copy(Sin,1,posMot-1)+mot2 // le mot à remplacer est au milieu else sIn := copy(Sin,1,posMot-1)+mot2 +copy(sin,posMot+tailleMot,tailleSin-(posMot+tailleMot-1)); posMot := pos(mot1,sIn); end; result := Sin; end; //-------------------------------------------------------------------------- // On vide les blancs en tête et queue, on converti la chaîne en majuscule // et on remplace les majuscules accentuées, le c avec cédille majuscule //-------------------------------------------------------------------------- // et l'e dans l'o majuscule Œ en lettre équivalent en majuscules normales Function prepare(sIn : string) : string; var tailleSin, i : integer; car : char; sOut : string; begin // mise en majuscule sIn := Trim(sIn); sIn := upperCase(sIn); tailleSin := length(sIn); sOut := ''; for i:= 1 to tailleSin do begin car := sIn[i]; CASE car of 'Â','Ä','À' : car := 'A'; 'Ç' : car := 'S'; 'È','É','Ê','Ë','Œ' : car := 'E'; 'Î','Ï' : car := 'I'; 'Ô','Ö' : car := 'O'; 'Ù','Û','Ü' : car := 'U'; END; sOut := sOut+car; end; // suppression des blancs et des tirets sIn := sOut; sOut := ''; for i := 1 to length(sIn) do if (sIn[i] <> ' ') and (sIn[i] <> '-') then sOut := sOut + sIn[i]; result := sOut; end; Function pow(x,y : integer) : double; var xx,yy : double; begin xx := x; yy := y; result := exp(xx*ln(yy)); end; //-------------------------------------------------------------------------- // corps du premier soundex //-------------------------------------------------------------------------- function soundex(sIn : string) : sound; type TabloLettres = array[1..26] of char; Const Encode : TabloLettres = ('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'); var iSX, iiSX : smallint; tailleSin : integer; sOut : string; begin // cas trivial : la chaîne est vide if sIn = '' then begin result := '0000'; exit; end; // on prepare la chaine sIn := prepare(sIn); // traitement du second effet de bord : chaîne de longueur 1 if length(sIn) = 1 then begin result := sIn+'000'; exit; end; // troisième effet de bord : la première lettre est un H on la retire du mot tailleSin := length(sIn); if sIn[1] = 'H' then sIn := copy(sIn,2,tailleSin-1); // traitement pour tous les autres cas // boucle sur la longueur de la chaîne cible tailleSIn := length(sIn); for iSX :=2 to tailleSIn do // si le caractère est compris entre les lettres A à Z : on transcode if sIn[iSX] in ['A'..'Z'] then sIn[iSX] := enCode[ord(sIn[iSX])-ord('A')+1] // sinon le caractère n'est pas compris entre A et Z : on pose un zero else sIn[iSX] := '0'; // on récupère la première lettre du mot sOut:=''; sOut := sIn[1]; // seconde phase de transcodage iiSX := 2; for iSX :=2 to tailleSIn do begin // si le caractère est un différent de zéro on retient if sIn[iSX] <> '0' then begin sout := sout+sIn[iSX]; iiSX := iiSX+1; end; // si l'on dépasse les 4 caractères, on quitte la boucle if iiSX > 4 then begin result := sOut; exit; end; end; // moins de 4 caractères : on complète par des zéros While length(sOut) < 4 do sout := sout+'0'; result := sOut; end; //-------------------------------------------------------------------------- // soundex2 francisé par Frédéric BROUARD - copyright Frédéric BROUARD //------------------------------------------------------------------------- function soundex2(sIn : string) : sound; type TabloVoyell = array[1..4] of char; TabloCombi1 = array[1..11,1..2] of string; TabloCombi2 = array[1..5,1..2] of string; Const Voyelle : TabloVoyell = ('E', 'I', 'O', 'U'); Combin1 : TabloCombi1 = (('GUI','KI'), ('GUE','KE'), ('GA','KA'), ('GO','KO'), ('GU','K'), ('CA','KA'), ('CO','KO'), ('CU','KU'), ('Q','K'), ('CC','K'), ('CK','K')); Combin2 : TabloCombi2 = (('ASA','AZA'), ('KN','NN'), ('PF','FF'), ('PH','FF'), ('SCH','SSS')); var i : integer; // indice de boucle lSin : integer; // longueur de la chaîne d'entrée prfx : string; // préfixe sIn2 : string; // sIn moins la première lettre let : string; // lettre begin // cas trivial : la chaîne est vide if sIn = '' then begin result := ' '; exit; end; // on prepare la chaine : étapes 1, 2 et 3 sIn := prepare(sIn); lSin := length(sIn); // traitement du second effet de bord : chaîne de longeur 1 if lSin = 1 then begin result := sIn+' '; exit; end; // étapes 1, 2, 3 et 4: élimine les blancs, met en majuscule, // convertit les accents et le c cédille sIn := prepare(sIn); // étape 5 : on remplace les consonnances primaires for i := 1 to 4 do sIn := SearchReplace(sIn,Combin1[i,1],Combin1[i,2]); // étape 6 : on remplace les voyelles sauf le Y et sauf la première par A lSin := length(sIn); sIn2 := copy(sIn,2,lSin-1); for i := 1 to 4 do sIn2 := SearchReplace(sIn2,Voyelle[i],'A'); sIn := sIn[1]+sIn2; // étape 7 : on remplace les préfixes lSin := length(sIn); if lSin>=2 then begin prfx := copy(sIn,1,2); if (prfx = 'KN') then prfx := 'NN'; if (prfx = 'PH') or (prfx = 'PF') then prfx := 'FF'; if lSin = 2 then sIn := prfx else sIn := prfx+copy(sIn,3,lSin-2); end; if lSin>=3 then begin prfx := copy(sIn,1,3); if (prfx = 'MAC') then prfx := 'MCC'; if (prfx = 'SCH') then prfx := 'SSS'; if (prfx = 'ASA') then prfx := 'AZA'; if lSin = 3 then sIn := prfx else sIn := prfx+copy(sIn,4,lSin-3); end; // étape 8 : on conserve la première lettre et on fait // les remplacements complémentaires sIn2 := copy(Sin,2,lSin-1); for i := 1 to 5 do sIn2 := SearchReplace(sIn2,Combin2[i,1],Combin2[i,2]); sIn := sIn[1]+sIn2; // étape 9 : suppression des H sauf CH ou SH lSin := length(sIn); sIn2 := ''; for i := 1 to lSin do // pas de H on conserve la lettre if (sIn[i] <> 'H') then begin sIn2 := SIn2+sIn[i]; continue; end else // le H est précédé d'un S ou d'un C on le conserve if (sIn[i-1] = 'C') or (sIn[i-1] = 'S') then sIn2 := Sin2+sIn[i]; sIn := Sin2; // étape 10 : suppression des Y sauf précédés d'un A lSin := length(sIn); sIn2 := ''; for i := 1 to lSin do // pas de Y on conserve la lettre if (sIn[i] <> 'Y') then begin sIn2 := SIn2+sIn[i]; continue; end else // le Y est précédé d'un A on le conserve if (sIn[i-1] = 'A') then sIn2 := Sin2+sIn[i]; sIn := Sin2; lSin := length(sIn); // étape 11 : on supprime les terminaisons A, T, D, S let := copy(sIn,lSin,1); if (let = 'A') or (let = 'D') or(let = 'S') or (let = 'T') then sIn := copy(sIn,1,lSin-1); // étape 12 : suppression de tous les A sauf en tête lSin := length(sIn); sIn2 := copy(sIn,1,1); for i := 2 to lSin do // pas de A on conserve la lettre if (sIn[i] <> 'A') then begin sIn2 := sIn2+sIn[i]; continue; end; sIn := Sin2; lSin := length(sIn); // étape 13 : on supprime les lettres répétitives let := copy(sIn,1,1); sIn2 := let; for i := 2 to lSin do begin if sIn[i] = let then continue; let := sIn[i]; Sin2 := Sin2 + sIn[i]; end; sIn := sIn2; // étape 14 : on ne retient que 4 caractères ou on complète avec des blancs while length(sIn) < 4 do Sin := Sin+' '; if length(sIn) > 4 then sIn := copy(sIn,1,4); result := sIn; end; //------------------------------------------------------------------------- // FONCTION PHONEX : copyright Frédéric BROUARD //------------------------------------------------------------------------- //function phonex(sIn : string) : integer; function phonex(sIn : string) : double; Type TabSonAI = array[1..4] of string; tabCarPhon = array[0..21] of char; Const SonAIA : TabSonAI = ('aina','eina','aima','eima'); SonAIE : TabSonAI = ('aine','eine','aime','eime'); SonAII : tabSonAI = ('aini','eini','aimi','eimi'); SonAIO : tabSonAI = ('aino','eino','aimo','eimo'); SonAIU : tabSonAI = ('ainu','einu','aimu','eimu'); CarPhon : TabCarphon = ('1','2','3','4','5','e','f','g','h','i','k','l','n','o','r','s','t','u','w','x','y','z'); var i,j,k : integer; car : char; p : integer; let, sin2 : string; sOut : array[1..10] of integer; begin // cas trivial : la chaîne est vide if sIn = '' then begin // result := 0; result := 0.0; exit; end; // mise en minuscules sIn := lowerCase(sIn); // remplacement des y par des i sIn := SearchReplace(sIn, 'y', 'i'); // remplacement des lettres accentuées for i:= 1 to length(sIn) do begin car := sIn[i]; CASE car of 'â','ä','à','Â','Ä','À' : car := 'a'; 'ç','Ç' : car := 's'; 'ë','œ','Ë','Œ' : car := 'e'; 'ï','î','Î','Ï' : car := 'i'; 'ô','ö','Ô','Ö' : car := 'o'; 'ù','û','ü','Ù','Û','Ü' : car := 'u'; 'é','ê','È','É','Ê' : car := 'y'; END; sIn[i] := car; end; // on retire les h muets for i := 1 to length(sIn) do begin p := pos('h',sIn); if p = 1 then sIn := copy(sIn,2, length(sIn)-1) else if not((sIn[p-1] = 'c') or (sIn[p-1] = 's')) then if p<length(sIn) then sIn := copy(sIn,1,p-1)+copy(sIn,p+1,length(sIn)-p) else sIn := copy(sIn,1,p-1); end; // remplacement des ph par des h sIn := SearchReplace(sIn, 'ph', 'f'); // rempacement de g qui sonnent k devant an, am, ain, aim sIn := searchReplace(sIn,'gan','kan'); sIn := searchReplace(sIn,'gain','kain'); sIn := searchReplace(sIn,'gam','kam4'); sIn := searchReplace(sIn,'gaim','kaim'); // remplacement du son AI for i := 1 to 4 do begin sIn := searchReplace(sIn,SonAIA[i],'yna'); sIn := searchReplace(sIn,SonAIE[i],'yne'); sIn := searchReplace(sIn,SonAII[i],'yni'); sIn := searchReplace(sIn,SonAIO[i],'yno'); sIn := searchReplace(sIn,SonAIU[i],'ynu'); end; // remplacement des groupes de 3 lettres sIn := searchReplace(sIn,'eau','o'); sIn := searchReplace(sIn,'oua','2'); sIn := searchReplace(sIn,'ein','4'); sIn := searchReplace(sIn,'ain','4'); // remplacement du son é sIn := searchReplace(sIn,'ai','y'); sIn := searchReplace(sIn,'ei','y'); sIn := searchReplace(sIn,'er','yr'); sIn := searchReplace(sIn,'ess','yss'); sIn := searchReplace(sIn,'et','yt'); sIn := searchReplace(sIn,'ez','yz'); // remplacement des groupes de 2 lettres sauf si voyelle ou son (1 à 4) Sin := SRSaufVoyelle(sIn,'an','1'); Sin := SRSaufVoyelle(sIn,'am','1'); Sin := SRSaufVoyelle(sIn,'en','1'); Sin := SRSaufVoyelle(sIn,'em','1'); Sin := SRSaufVoyelle(sIn,'in','4'); // remplacement du sch Sin := searchReplace(sIn,'sch','5'); // remplacement du s si précédé et suivi d'une voyelle ou son (1 à 4) sin := SRSauf2Voyelle(sIn,'s','z'); // remplacement des groupes de 2 lettres divers Sin := searchReplace(sIn,'oe','e'); Sin := searchReplace(sIn,'eu','e'); Sin := searchReplace(sIn,'au','o'); Sin := searchReplace(sIn,'oi','2'); Sin := searchReplace(sIn,'oy','2'); Sin := searchReplace(sIn,'ou','3'); Sin := searchReplace(sIn,'ch','5'); Sin := searchReplace(sIn,'sh','5'); Sin := searchReplace(sIn,'ss','s'); Sin := searchReplace(sIn,'sc','s'); // remplacement du c par s s'il est suivi d'un e ou d'un i Sin := searchReplace(sIn,'ce','se'); Sin := searchReplace(sIn,'ci','si'); // remplacement divers Sin := searchReplace(sIn,'c','k'); Sin := searchReplace(sIn,'q','k'); Sin := searchReplace(sIn,'qu','k'); Sin := searchReplace(sIn,'ga','ka'); Sin := searchReplace(sIn,'go','ko'); Sin := searchReplace(sIn,'gu','ku'); Sin := searchReplace(sIn,'gy','ky'); Sin := searchReplace(sIn,'g2','k2'); Sin := searchReplace(sIn,'g1','k1'); Sin := searchReplace(sIn,'g3','k3'); Sin := searchReplace(sIn,'a','o'); Sin := searchReplace(sIn,'d','t'); Sin := searchReplace(sIn,'p','t'); Sin := searchReplace(sIn,'j','g'); Sin := searchReplace(sIn,'b','f'); Sin := searchReplace(sIn,'v','f'); Sin := searchReplace(sIn,'m','n'); // suppression des lettres dupliquées let := copy(sIn,1,1); sIn2 := let; for i := 2 to length(Sin) do begin if sIn[i] = let then continue; let := sIn[i]; Sin2 := Sin2 + sIn[i]; end; sIn := sIn2; // suppression des terminaisons sIn2 := copy(sIn,length(sIn),1); if (sIn2 = 't') or (sIn2 = 'x') or (sIn2 = 's') or (sIn2 = 'z') then sIn := copy(sIn,1,length(sIn)-1); // suppression des caractères non autorisés j := 10; for i := 1 to length(sIn) do begin if j<1 then break; for k:=0 to 21 do if sIn[i] = carPhon[k] then begin sout[j] := k; j := j-1; end

L'art des « Soundex »

Préambule

1. Le principe

2. Le premier Soundex

3. Le code

4. Soundex 2

5. Phonex

6. Tests

7. Implémentation dans les bases de données

8. En complément

8.1. HAMMING et sa différence

8.2. Levenshtein et sa distance