L'art des « Soundex »

Date de publication : 10/02/2004

Par SQLPro (autres articles) (CV)
 

niveau : avancé

Non les soundex ne sont pas de petites bêtes rampantes que l’on tue à l’aide d’un insecticide… Ce sont en fait des mécanismes de recherche portant sur la consonance des mots. Ils sont en général utilisé dans de très grandes bases de données pour lesquelles la recherche approchée d’un nom peut être d’une très grande utilité...
Nous avons réalisé ces petites bêtes, à l’aide de DELPHI 3. Mais n’importe quel autre langage performant (C++, Java) peut être utilisé à ces fins.

Préambule

1. Le principe

2. Le premier Soundex

• On retranscrit le mot en majuscules
• On conserve la première lettre du mot
• On élimine ensuite toutes les voyelles, le H et le W
• On transcode ensuite les lettres restantes à l’aide de la table suivante

• On élimine ensuite toutes les paires consécutives de chiffres dupliquées
• On ne conserve que 4 caractères du Soundex ainsi obtenu, et on le complète par des zéros le cas échéant

3. Le code

implementation

uses
   sysUtils;

// 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;

// corps de la fonction 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 := copy(sOut,1,1)+'000';
   exit;
end;

// 3e effet de bord : la première lettre est un H on la retire du mot
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];
//      sout[iiSX] := 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;

4. Soundex 2

• Éliminer les blancs à droite et à gauche du nom
• Convertir le nom en majuscule
• Convertir les lettres accentuées et le c cédille en lettres non accentuées
• Eliminer les blancs et les tirets
• Remplacer les groupes de lettres suivantes par leur correspondance (en conservant l’ordre du tableau) :

• Remplacer toutes les voyelles sauf le Y par A exceptée s’il y a un A en tête
• Remplacer les préfixes suivants par leur correspondance :

• Supprimer les H sauf s’ils sont précédés par C ou S
• Supprimer les Y sauf s’il est précédé d’un A
• Supprimer les terminaisons suivantes A, T, D et S
• Enlever tous les A sauf le A de tête s’il y en a un
• Enlever toutes les sous chaînes de lettre répétitives
• Conserver les 4 premiers caractères du mot et si besoin le compléter avec des blancs pour obtenir 4 caractères

// 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;
// ATTENTION : 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;

// soundex2 francisé par 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 (i>1) and ((sIn[i-1] = 'C') or (sIn[i-1] = 'S'))
      then
          sIn2 := Sin2+sIn[i];
sIn := Sin2;
lSin := length(sIn);

// é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;

5. Phonex

6. Tests

   Soundex      7 secondes
   Soundex2    11 secondes
   Phonex      14 secondes

• Pour FAURE, il a récupéré : FARRE, FAURE, FORT, FOURR, PHAURE, VARD et VAURE
• Pour PEREZ, il a récupéré : PERET, PEREZ, PERRAIX, PERRET, PEYRET, DEREI, DHERET
• Pour GROS, il a récupéré : GRAU, GROS, GROSS, GROZ, GRAS, GRASS
• Pour GAUTHIER, il a récupéré : GAUTHIER, GAUTIER, GOUDIER, GOUTHIER, CADIER, CATTIER, COPIER, COTTIER, COUPIER, COUTIER, tandis que Soundex n’a pas récupéré GOUTHIER...
• Pour MOULIN, il récupère : MALLEIN,MOLEINS, MOLIN, MOULIN, NAULIN
• Pour ROUSSEAU, il récupère ROUSSEAU, ROUSSEAUX, ROUSSOT, RASSAT, RASSSAT, ROSSAT, ROSSO
• Et pour REY : RAIS, RAY, REIX, REY et REYT

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

Select * from T_PERSONNE 
Where SOUNDEX(:LeNom) = SOUNDEX(T_PERSONNE.NOM_PERS)

Select * from T_PERSONNE 
Where SOUNDEX(:LeNom) = T_PERSONNE.SOUNDEX_NOM_PERS

• http://www.bradandkathy.com/genealogy/overviewofsoundex.html

• http://aspell.sourceforge.net/metaphone/

8. En complément

8.1. HAMMING et sa différence

8.2. Levenshtein et sa distance

PORTES
PORTER

PORTE
PORTER

POTES
PORTES

POTE
POSTER

2 : POTE    étape 0
    POSTE   étape 1
    POSTER  étape 2

DEPORTEES
POSTERS

4 : POSTERS
    D POSTERS  étape 1
    DEPOSTERS  étape 2
    DEPORTERS  étape 3
    DEPORTEES  étape 4

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;
end;

// conversion en flottant
result := 0.0;
for j := 10 downTo 1
do
  result := result+sout[j]*pow(j-1,22);

end;

end.

package Soundex_fr;

require Exporter;
use strict;
use locale;

our $VERSION = 'v1.0.0';
our @ISA = qw(Exporter);
our @EXPORT = qw(soundex_fr);

# $soundex_nocode est utile pour indiquer le soundex d'un mot vide
# Par défaut on retourne undef mais vous pouvez préférer 'ZZZZ' ou 'NULL'

our $soundex_nocode = undef;

sub soundex_fr {
 my @a = @_;
 my $s;

 push(@a, '') unless @a;  ## Pas de paramètre d'appel

 foreach (@a) {
  if ($_ eq '') {
   $_ = $soundex_nocode;
   next;
  }

  # On prepare la chaine : etapes 1, 2, 3, 4
  # 1. Elimine les blancs ˆ droite et ˆ gauche du nom
  s/^\s+//;
  s/\s+$//; 

  # 2. Converti le nom en majuscule
  $_ = uc($_); 

  # 3. Converti les lettres accentuées et le c cédille en lettres non accentuées
  # NB : les lettres accentuées ne sont pas capitalisées :-(
  tr/\xE0-\xE6\xE7\xE8-\xEB\xEC-\xEF\xF1\xF2-\xF6\xF9-\xFC\xFD\xFF/AAAAAAACEEEEIIIINOOOOOUUUUYY/;
  tr/\xC0-\xC6\xC7\xC8-\xCB\xCC-\xCF\xD1\xD2-\xD6\xD9-\xDC\xDD/AAAAAAACEEEEIIIINOOOOOUUUUY/;

  # 4. Elimine tous les autres symboles 
  tr/A-Z//cd;

  # Chaîne de longeur 1
  next if (length($_) == 1);

  # Etape 5 : on remplace les consonnances primaires
  s/GUI/KI/g;
  s/GUE/KE/g;
  s/GA/KA/g;
  s/GO/KO/g;
  s/GU/K/g;
  s/CA/KA/g;
  s/CO/KO/g;
  s/CU/KU/g;
  s/Q/K/g;
  s/CC/K/g;
  s/CK/K/g;

  # Etape 6 : on remplace les voyelles par A, sauf le Y et la première lettre
  s/^(.)(.*)$/$2/; # le premier caractère dans $1, le reste dans $_
  tr/EIOU/AAAA/;
  $_ = $1 . $_;

  # Etape 7 : on remplace les préfixes
  s/^KN/NN/;
  s/^(PH|PF)/FF/;
  s/^MAC/MCC/;
  s/^SCH/SSS/;
  s/^ASA/AZA/;

  # Etape 8 : on conserve la première lettre 
  # et on fait les remplacements complémentaires
  s/^(.)(.*)$/$2/; # le premier caractère dans $1, le reste dans $_
  $s = $1;   # conserve le premier caractere
  s/KN/NN/;
  s/(PH|PF)/FF/;
  s/MAC/MCC/;
  s/SCH/SSS/;
  s/ASA/AZA/;
  $_ = $s . $_;

  # Etape 9 : suppression des H sauf CH ou SH
  s/CH/C@/g; s/SH/S@/g;
  s/H//;
  s/C@/CH/g; s/S@/SH/g;

  # Etape 10 : suppression des Y sauf précédés d'un A
  s/AY/A@/g; 
  s/Y//;
  s/A@/AY/g;

  # Etape 11 : on supprime les terminaisons A, T, D, S
  s/[ATDS]$//;

  # Etape 12 : suppression de tous les A sauf en tête
  s/^(.)(.*)$/$2/; # le premier caractère dans $1, le reste dans $_
  $s = $1;
  s/A//g;
  $_ = $s . $_;

  # Etape 13 : on supprime les lettres répétitives
  my @ac = split(//);
  $_ = '';
  for (my $i=0; $i < $#ac; $i++) {
    $_ .= $ac[$i] unless ($ac[$i] eq $ac[$i + 1]);
  }
  $_ .= $ac[$#ac];

  # Etape 14 : on ne retient que 4 caractères
  s/^(.{1,4}).*$/$1/;

 }

 wantarray ? @a : shift @a;
}

1;
__END__

=head1 NAME

Text::Soundex_fr - Soundex adapté au fran?ais

=head1 UTILISATION de Soundex_fr

 use Soundex_fr;

 $Soudex_fr::soundex_nocode = 'NULL';  # le soundex d'un mot vide

 $sound  = soundex_fr($word);
 @sounds = soundex_fr(@words);

=head1 DESCRIPTION

Algorithme décrit par Frédéric Bouchard <brouardf@club-internet.fr>

http://sqlpro.multimania.com/Soundex/SQL_AZ_soundex.htm

Soundex_fr est un algorithme francisé du Soundex, et dérivé de l'algorithme décrit dans le livre de 
Joe Celko - SQL avancé , parue en 1995 chez Thomson International Publishing. Il repose sur l'algorithme 
de Gus Baird (Georgia Tech) énoncé en page 85. 

Contrairement au précédent qui ne fait appel qu'à des chiffres à l'exception du premier caractère, cette 
nouvelle version conserve la plupart des lettres. En comparant les deux versions, on trouve, pour la 
première un nombre de combinaisons possibles de 26x10x10x10 = 26 000 alors que dans cette version améliorée 
le nombre de combinaisons différentes monte jusqu'aux environs de 20x20x20x20 = 160000 
Il se révèle donc plus performant dans de nombreux cas, c'est à dire qu'il permet de sélectionner moins 
d'occurrence lors des recherches avec le même encombrement de 4 caractères. 

=head1 AUTEUR

Jean-Marc Pennel <jmp@noos.fr<
http://www.suricate.net/

=cut

use Soundex_fr;
use strict;

my $mot = 'Bernard';
my @mots = ('Martin', 'Michel', 'Jean-Marc', 'Frédéric', 'Valérie');

print "\nSoundex_fr test :\n";

print "Test 1 : $mot => ";
print soundex_fr($mot), "\n";

print "Test 2 : (  ", (map {$_ .= '  '} @mots), ") => ( ";
print map {$_ .= '  '} soundex_fr(@mots);
print ") \n";

print "Test 3 : avec un mot vide ou pas d'argument, doit retourner 'NULL' => ";
$Soundex_fr::soundex_nocode = "NULL";
print soundex_fr(), "\n";

print "Fin du test.";

rem   ***************************************************************
rem   *                                                           *
rem   *                      phonex.sql                             *
rem   *                                                             *
rem   *                   *
rem   *  Ce script créé 2 tables et une fonction  Phonex dans le    *
rem   *  même schéma .                                              *
rem   *  Pensez à donner le privilège d'execution de la fonction    *
rem   *  aux autres user .                                          *
rem   *  Cette fonction fonctionne comme un SOUNDEX amélioré.       *
rem   *                                                             *
rem   *  Elle est due aux travaux de Monsieur FREDERIC BROUARD      *
rem   *  alias SQLPro qui l'a développé sous Delphi .               *
rem   *  (http://sqlpro.developpez.com/Soundex/SQL_AZ_soundex.html) *
rem   *  pour obtenir les sources et + amples infos .               *
rem   *  Merci à lui de m'avoir permis d'effectuer ce portage en    *
rem   *  PLS/SQL :)                                                 *
rem   *            *
rem   *  Cette fonction Oracle est entièrement libre de droit, vous *
rem   *  pouvez l'utiliser sans aucune limite ni restriction,       *
rem   *  modifier les sources a votre convenance etc ... si vous    *
rem   *  l'améliorez je veux bien etre tenu au courant ;)           *
rem   *                                                             *
rem   *  PS : Libre a vous de passer par 2 tables ou de créer un    *
rem   *  type varray pour l'occasion . Néanmoins le fait de passer  *
rem   *  par 2 tables pour stocker les types de sons assure une     *
rem   *  compatibilité dès la version 7.3 d'Oracle !                *
rem   *=============================================================*
rem   *        Auteur : Julien Vauconsant alias UbiK             *
rem   *             jvauconsant@multilignes.fr                      *
rem   *=============================================================*
rem   *    Créé le 23/12/2002 ~~~~~~ Dernière modif le 26/12/2002   *
rem   *                                                             *
rem   *         System (création et tests) : Oracle 8.1.7.3         *
rem   ***************************************************************
 
 
create table son ( 
son_aia varchar2(4), 
son_aie varchar2(4), 
son_aii varchar2(4), 
son_aio varchar2(4), 
son_aiu varchar2(4));

insert into son(son_aia,son_aie,son_aii,son_aio,son_aiu) values('aina','aine','aini','aino','ainu');
insert into son(son_aia,son_aie,son_aii,son_aio,son_aiu) values('eina','eine','eini','eino','einu');
insert into son(son_aia,son_aie,son_aii,son_aio,son_aiu) values('aima','aime','aimi','aimo','aimu');
insert into son(son_aia,son_aie,son_aii,son_aio,son_aiu) values('eima','eime','eimi','eimo','eimu');
 

create table carphon ( 
tabcarphon varchar2(1),
codecarphon number);

insert into carphon(tabcarphon,codecarphon) values('1',1);
insert into carphon(tabcarphon,codecarphon) values('2',2);
insert into carphon(tabcarphon,codecarphon) values('3',3);
insert into carphon(tabcarphon,codecarphon) values('4',4);
insert into carphon(tabcarphon,codecarphon) values('5',5);
insert into carphon(tabcarphon,codecarphon) values('e',6);
insert into carphon(tabcarphon,codecarphon) values('f',7);
insert into carphon(tabcarphon,codecarphon) values('g',8);
insert into carphon(tabcarphon,codecarphon) values('h',9);
insert into carphon(tabcarphon,codecarphon) values('i',10);
insert into carphon(tabcarphon,codecarphon) values('k',11);
insert into carphon(tabcarphon,codecarphon) values('l',12);
insert into carphon(tabcarphon,codecarphon) values('n',13);
insert into carphon(tabcarphon,codecarphon) values('o',14);
insert into carphon(tabcarphon,codecarphon) values('r',15);
insert into carphon(tabcarphon,codecarphon) values('s',16);
insert into carphon(tabcarphon,codecarphon) values('t',17);
insert into carphon(tabcarphon,codecarphon) values('u',18);
insert into carphon(tabcarphon,codecarphon) values('w',19);
insert into carphon(tabcarphon,codecarphon) values('x',20);
insert into carphon(tabcarphon,codecarphon) values('y',21);
insert into carphon(tabcarphon,codecarphon) values('z',22);
commit;

/************** CREATION DE LA FONCTION PHONEX **************/

CREATE OR REPLACE FUNCTION PHONEX (l_in in varchar2)
return float is

cursor c1 is (select son_aia, son_aie, son_aii, son_aio, son_aiu from son);
cursor c2 is (select tabcarphon,codecarphon from carphon);

custom_error exception;
SonAi c1%rowtype;
KPhon c2%rowtype;
v_string varchar2(4000);
result float;
i integer;
p integer;
j integer;
cpt integer;
sortie integer;
letter char(1);
v_string_bis varchar2(4000);

BEGIN

-- ouverture du curseur
open c1;
-- initialisation des variables
v_string := replace(l_in,chr(32),null); -- suppression des espaces
p := 1;
cpt:=0;
sortie := 6; -- condition de sortie=0
result:=0.0;
j:= length(v_string);

-- chaine vide en entrée
if (v_string is null) then
  result:=0.0;
end if;

-- passage en minuscule de la chaine en entrée
v_string := lower(v_string);

-- remplacement des ç par des ss
v_string := replace(v_string,'ç','ss');
v_string := replace(v_string,'Ç','ss');

-- remplacement des y par des i
v_string := replace(v_string,'y','i');

-- remplacement des e accentués par y (son et)
v_string := translate(v_string,'ÉÈÊËéèêë','yyyyyyyy');

-- remplacement des lettres accentués
v_string := translate(v_string,'ÀÄÂâäàÇçÉÈÊËéèêëÏÎïîÖÔöôÜÛÙüûù','aaaaaacceeeeeeeeiiiioooouuuuuu');

-- suppression des h muets ...
-- ... en premiere ou derniere position de chaine ...

while (substr(v_string,1,1)='h' or substr(v_string,j,1)='h') loop
  v_string := rtrim(ltrim(v_string,'h'),'h');
end loop;
-- ... autres cas
for i in 2..j
loop
  if ( (substr(v_string,i,1)='h') and ( substr(v_string,i-1,1) not in ('c','s','p') ) ) then
    v_string := substr(v_string,1,i-1)||substr(v_string,i+1);
 j:=j-1;
  end if;
end loop;

-- remplacement des er par des ez en fin de mot
-- BOUCHEZ et BOUCHER
if substr(v_string,length(v_string)-1,2) = 'er' then
   v_string := substr(v_string,1,length(v_string)-2) || 'ez';
end if;

-- remplacement des ss par des sse en fin de mot
-- choultess et choultesse
if substr(v_string,length(v_string)-1,2) = 'ss' then
   v_string := substr(v_string,1,length(v_string)-2) || 'sse';
end if;

-- remplacement des ph par des f
v_string := replace(v_string,'ph','f');

-- remplacement des g sonnant k
v_string := replace(v_string,'gan','kan');
v_string := replace(v_string,'gain','kain');
v_string := replace(v_string,'gam','kam');
v_string := replace(v_string,'gaim','kaim');

-- remplacement du son AI
loop
  fetch c1 into SonAI;
  exit when c1%notfound;
  v_string := replace(v_string,SonAi.son_aia,'yna');
  v_string := replace(v_string,SonAi.son_aie,'yne');
  v_string := replace(v_string,SonAi.son_aii,'yni');
  v_string := replace(v_string,SonAi.son_aio,'yno');
  v_string := replace(v_string,SonAi.son_aiu,'ynu');
end loop;
close c1;

-- remplacement des groupes de 3 lettres
v_string := replace(v_string,'eau','o');
v_string := replace(v_string,'oua','2');
v_string := replace(v_string,'ein','4');
v_string := replace(v_string,'ain','4');
v_string := replace(v_string,'eim','4');
v_string := replace(v_string,'aim','4');

-- remplacement du son é
v_string := replace(v_string,'ai','y');
v_string := replace(v_string,'ei','y');
v_string := replace(v_string,'er','yr');
v_string := replace(v_string,'ess','yss');
v_string := replace(v_string,'et','yt');
v_string := replace(v_string,'ez','yz');

v_string := replace(v_string,'oe','e');
v_string := replace(v_string,'eu','e');
v_string := replace(v_string,'au','o');

-- remplacement des groupes de 2 lettres sauf si le groupe est suivi d'une voyelle ou d'un son 1 à 4
while (sortie>0)
loop
  -- an
  p := instr(v_string,'an');
  if(p=0) then
    sortie := sortie-1;
  else if substr(v_string,p+2,1) not in ('a','e','i','o','u','y','1','2','3','4') then
    v_string := substr(v_string,1,p-1)||'1'||substr(v_string,p+2);
  else if length(v_string) = p+1 then
    v_string := substr(v_string,1,p-1)||'1';
    end if;
   end if;
  end if;
  -- am
  p := instr(v_string,'am');
  if(p=0) then
    sortie := sortie-1;
  else if substr(v_string,p+2,1) not in ('a','e','i','o','u','y','1','2','3','4') then
    v_string := substr(v_string,1,p-1)||'1'||substr(v_string,p+2);
  else if length(v_string) = p+1 then
    v_string := substr(v_string,1,p-1)||'1';
    end if;
   end if;
  end if;
  -- en
  p := instr(v_string,'en');
  if(p=0) then
    sortie := sortie-1;
  else if substr(v_string,p+2,1) not in ('a','e','i','o','u','y','1','2','3','4') then
    v_string := substr(v_string,1,p-1)||'1'||substr(v_string,p+2);
  else if length(v_string) = p+1 then
    v_string := substr(v_string,1,p-1)||'1';
    end if;
   end if;
  end if;
  -- em
  p := instr(v_string,'em');
  if(p=0) then
    sortie := sortie-1;
  else if substr(v_string,p+2,1) not in ('a','e','i','o','u','y','1','2','3','4') then
    v_string := substr(v_string,1,p-1)||'1'||substr(v_string,p+2);
  else if length(v_string) = p+1 then
    v_string := substr(v_string,1,p-1)||'1';
    end if;
   end if;
  end if;
  -- in
  p := instr(v_string,'in');
  if(p=0) then
    sortie := sortie-1;
  else if substr(v_string,p+2,1) not in ('a','e','i','o','u','y','1','2','3','4') then
    v_string := substr(v_string,1,p-1)||'4'||substr(v_string,p+2);
  else if length(v_string) = p+1 then
    v_string := substr(v_string,1,p-1)||'4';
    end if;
   end if;
  end if;
  -- un
  p := instr(v_string,'un');
  if(p=0) then
    sortie := sortie-1;
  else if substr(v_string,p+2,1) not in ('a','e','i','o','u','y','1','2','3','4') then
    v_string := substr(v_string,1,p-1)||'4'||substr(v_string,p+2);
  else if length(v_string) = p+1 then
    v_string := substr(v_string,1,p-1)||'4';
    end if;
   end if;
  end if;
end loop;

-- remplacement du sch
v_string := replace(v_string,'sch','5');

-- remplacement du s si précédé ET suivi d'une voyelle ou d'un son 1 à 4
for i in 2..length(v_string)
loop
  if (substr(v_string,i,1)='s') then
    if ( (substr(v_string,i-1,1) ) in ('a','e','i','o','u','y','1','2','3','4') ) AND
    ( (substr(v_string,i+1,1) ) in ('a','e','i','o','u','y','1','2','3','4') ) then
      v_string := substr(v_string,1,i-1)||'z'||substr(v_string,i+1);
 end if;
  end if;
end loop;

-- Remplacement de groupes de 2 lettres divers
v_string := replace(v_string,'oe','e');
v_string := replace(v_string,'eu','e');
v_string := replace(v_string,'au','o');
v_string := replace(v_string,'oi','2');
v_string := replace(v_string,'oy','2');
v_string := replace(v_string,'ou','3');
v_string := replace(v_string,'ch','5');
v_string := replace(v_string,'sh','5');
v_string := replace(v_string,'ss','s');
v_string := replace(v_string,'sc','s');

-- Remplacement du CHU par CHOU
v_string := replace(v_string,'5u','53');

-- Remplacement du c par s s'il est suivi d'un e ou d'un i
v_string := replace(v_string,'ce','se');
v_string := replace(v_string,'ci','si');

/************* Remplacements divers *************/

v_string := replace(v_string,'c','k');
v_string := replace(v_string,'qu','k');
v_string := replace(v_string,'q','k');

v_string := replace(v_string,'ga','ka');
v_string := replace(v_string,'go','ko');
v_string := replace(v_string,'gu','ku');
v_string := replace(v_string,'gy','ky');
v_string := replace(v_string,'g2','k2');
v_string := replace(v_string,'g1','k1');
v_string := replace(v_string,'g3','k3');

v_string := replace(v_string,'a','o');
v_string := replace(v_string,'d','t');
v_string := replace(v_string,'p','t');
v_string := replace(v_string,'j','g');
v_string := replace(v_string,'b','f');
v_string := replace(v_string,'v','f');
v_string := replace(v_string,'m','n');

-- Suppression des lettres dupliquées
letter := substr(v_string,1,1);
v_string_bis := letter;
for i in 2..length(v_string)
loop
  if (substr(v_string,i,1) != letter) then
    letter := substr(v_string,i,1);
 v_string_bis:= v_string_bis||letter;
  end if;
end loop;
v_string := v_string_bis;

-- Suppression des terminaisons
v_string_bis := substr(v_string,length(v_string),1);
if (v_string_bis in ('t','x','s','z') ) then
  v_string := substr(v_string,1,length(v_string)-1);
end if;

-- Conversion des caracteres en float
j := 10;
for i in 1..length(v_string)
loop
open c2;
  while j>1 loop
   fetch c2 into KPhon;
   exit when c2%notfound;
   if (substr(v_string,i,1) = KPhon.tabcarphon) then
  cpt:= cpt-1;
  result:=result+(KPhon.codecarphon*power(22,cpt));
  j := j-1;
   end if;
  end loop;
close c2;
end loop;

return result;

exception
when custom_error then
raise_application_error(-20100,'pb sur'||l_in);
end;

function soundex2( $sIn )
{
   // Si il n'y a pas de mot, on sort immédiatement
   if ( $sIn === '' ) return '    ';
   // On met tout en minuscule
   $sIn = strtoupper( $sIn );
   // On supprime les accents
   $sIn = strtr( $sIn, 'ÂÄÀÇÈÉÊËŒÎÏÔÖÙÛÜ', 'AAASEEEEEIIOOUUU' );
   // On supprime tout ce qui n'est pas une lettre
   $sIn = preg_replace( '`[^A-Z]`', '', $sIn );
   // Si la chaîne ne fait qu'un seul caractère, on sort avec.
   if ( strlen( $sIn ) === 1 ) return $sIn . '   ';
   // on remplace les consonnances primaires
   $convIn = array( 'GUI', 'GUE', 'GA', 'GO', 'GU', 'CA', 'CO', 'CU', 'Q', 'CC', 'CK' );
   $convOut = array( 'KI', 'KE', 'KA', 'KO', 'K', 'KA', 'KO', 'KU', 'K','K', 'K' );
   $sIn = str_replace( $convIn, $convOut, $sIn );
   // on remplace les voyelles sauf le Y et sauf la première par A
   $sIn = preg_replace( '`(?<!^)[EIOU]`', 'A', $sIn );
   // on remplace les préfixes puis on conserve la première lettre
   // et on fait les remplacements complémentaires
   $convIn = array( '`^KN`', '`^(PH|PF)`', '`^MAC`', '`^SCH`', '`^ASA`', '`(?<!^)KN`', '`(?<!^)(PH|PF)`', '`(?<!^)MAC`',
                    '`(?<!^)SCH`','`(?<!^)ASA`' );
   $convOut = array( 'NN', 'FF', 'MCC', 'SSS', 'AZA', 'NN', 'FF', 'MCC', 'SSS', 'AZA' );
   $sIn = preg_replace( $convIn, $convOut, $sIn );
   // suppression des H sauf CH ou SH
   $sIn = preg_replace( '`(?<![CS])H`', '', $sIn );
   // suppression des Y sauf précédés d'un A
   $sIn = preg_replace( '`(?<!A)Y`', '', $sIn );
   // on supprime les terminaisons A, T, D, S
   $sIn = preg_replace( '`[ATDS]$`', '', $sIn );
   // suppression de tous les A sauf en tête
   $sIn = preg_replace( '`(?!^)A`', '', $sIn );
   // on supprime les lettres répétitives
   $sIn = preg_replace( '`(.)\1`', '$1', $sIn );
   // on ne retient que 4 caractères ou on complète avec des blancs
   return substr( $sIn . '    ', 0, 4);
}