L'art des « Soundex »

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);
}