ATOUTFOX
COMMUNAUTÉ FRANCOPHONE DES PROFESSIONNELS FOXPRO
Visual FoxPro : le développement durable

Une fonction PHONEX pour remplacer un SOUNDEX inexploitable en français   



L'auteur

Christophe Chenavier
France France
Membre Simple
# 0000000023
enregistré le 14/10/2004
http://www.corwin.fr
53 ans
CHENAVIER Christophe
80440 BOVES
de la société Corwin
Fiche personnelle


Note des membres
pas de note

Contributions > 01 - PRG : Programmation

Une fonction PHONEX pour remplacer un SOUNDEX inexploitable en français
# 0000000409
ajouté le 28/02/2007 07:57:32 et modifié le 28/02/2007
consulté 5635 fois
Niveau débutant

Version(s) Foxpro :
VFP 9.0
VFP 8.0
VFP 7.0
VFP 6.0

Description
C'est parce que la fonction SOUNDEX de VFP est inexploitable en français que j'ai recherché un algo adapté.
Voici le lien qui me l'a fourni : http://sqlpro.developpez.com/cours/soundex/
Je l'ai ensuite porté en VFP après l'avoir adapté pour une meilleure prise en charge des noms de famille.



Code source :
*!*    Objet : Implémention d'une fonction de reconnaissance phonétique
*!*    Auteur : C.Chenavier
*!*    Version : 1.00 - 14/07/2003
*!*
*!*    Algorithme d'origine par Frédéric BROUARD (31/3/99) avec l'aide
*!*    de Florence MARQUIS, orthophoniste pour la mise au point.
*!*    Voir : http://sqlpro.developpez.com/cours/soundex/
*!*
*!*    Améliorations apportées par Monique Kijko (Alfa informatique)
*!*    et Christophe Chenavier (Corwin)

FUNCTION Phonex

LPARAMETER cString

LOCAL I, c1, c2, cResultat, cLettre, cCar, cGroupe

M.c1="ÂÀÄÅÁÃÉÊÈËÎÏÌÍÔÖÒÓÕÛÜÙÚÇ-YÝÑ"
M.c2="AAAAAAYYYYIIIIOOOOOUUUUS IIN"

** É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 Y par des I

M.cString = STRTRAN(CHRTRAN(UPPER(ALLTRIM(M.cString)), M.c1, M.c2), ' ')

** Remplacer le C par un S s'il est suivi d'un E ou d'un I ou d'un Y
M.cString = STRTRAN(M.cString, "CE""SE")
M.cString = STRTRAN(M.cString, "CI""SI")
M.cString = STRTRAN(M.cString, "CY""SY")

** Replacer Œ par E
M.cString = CHRTRAN(M.cString, 'Œ''E')

** Remplacer PH par F
M.cString = STRTRAN(M.cString, "PH""F")

** Supprimer les H qui ne sont pas précédés de C ou de S

M.cString = STRTRAN(M.cString, "CH""$C$")
M.cString = STRTRAN(M.cString, "SH""$S$")
M.cString = STRTRAN(M.cString, "H")
M.cString = STRTRAN(M.cString, "$C$""CH")
M.cString = STRTRAN(M.cString, "$S$""SH")

** Remplacer les groupes de lettres suivantes :

M.cString = STRTRAN(M.cString, "GAN""KAN")
M.cString = STRTRAN(M.cString, "GAM""KAM")
M.cString = STRTRAN(M.cString, "GAIN""KAIN")
M.cString = STRTRAN(M.cString, "GAIM""KAIM")

** Remplacer les occurrences suivantes,
** si elles sont suivies par une lettre a, e, i, o, u ou y :

FOR I = 1 TO 5
    M.cLettre = SUBSTR("AEIOUY", I, 1)
    M.cString = STRTRAN(M.cString, "AIN"+M.cLettre, "YN"+M.cLettre)
    M.cString = STRTRAN(M.cString, "EIN"+M.cLettre, "YN"+M.cLettre)
    M.cString = STRTRAN(M.cString, "AIM"+M.cLettre, "YN"+M.cLettre)
    M.cString = STRTRAN(M.cString, "EIM"+M.cLettre, "YN"+M.cLettre)
ENDFOR

** Remplacer les groupes de 3 lettres (sons 'o', 'oua', 'ein') :

M.cString = STRTRAN(M.cString, "EAU"'O')
M.cString = STRTRAN(M.cString, "OUA"'2')
M.cString = STRTRAN(M.cString, "EIN"'4')
M.cString = STRTRAN(M.cString, "AIN"'4')
M.cString = STRTRAN(M.cString, "EIM"'4')
M.cString = STRTRAN(M.cString, "AIM"'4')

** Remplacer le son ‘é’ par 'y':

*M.c1="ÉÈÊ"
*M.c2="YYY"

*M.cString = CHRTRAN(M.cString, M.c1, M.c2)
M.cString = STRTRAN(M.cString, "AI"'Y')
M.cString = STRTRAN(M.cString, "EI"'Y')
M.cString = STRTRAN(M.cString, "ER""YR")
M.cString = STRTRAN(M.cString, "ESS""YSS")
M.cString = STRTRAN(M.cString, "ET""YT")
M.cString = STRTRAN(M.cString, "EZ""YZ")

** Remplacer les groupes de 2 lettres suivantes (son ‘an’ et ‘in’),
** sauf s’ils sont suivis par une lettre a, e, i, o, u ou un son 1 à 4 :

FOR I = 1 TO 5
    M.cGroupe = SUBSTR("ANAMENEMIN", (I-1)*2+1, 2)
    M.cString = STRTRAN(M.cString, M.cGroupe+'A'"$1$")
    M.cString = STRTRAN(M.cString, M.cGroupe+'E'"$2$")
    M.cString = STRTRAN(M.cString, M.cGroupe+'I'"$3$")
    M.cString = STRTRAN(M.cString, M.cGroupe+'O'"$4$")
    M.cString = STRTRAN(M.cString, M.cGroupe+'U'"$5$")
    M.cString = STRTRAN(M.cString, M.cGroupe+'1'"$6$")
    M.cString = STRTRAN(M.cString, M.cGroupe+'2'"$7$")
    M.cString = STRTRAN(M.cString, M.cGroupe+'3'"$8$")
    M.cString = STRTRAN(M.cString, M.cGroupe+'4'"$9$")
    M.cString = STRTRAN(M.cString, M.cGroupe, IIF(I<5, '1''4'))
    M.cString = STRTRAN(M.cString, "$1$", M.cGroupe+'A')
    M.cString = STRTRAN(M.cString, "$2$", M.cGroupe+'E')
    M.cString = STRTRAN(M.cString, "$3$", M.cGroupe+'I')
    M.cString = STRTRAN(M.cString, "$4$", M.cGroupe+'O')
    M.cString = STRTRAN(M.cString, "$5$", M.cGroupe+'U')
    M.cString = STRTRAN(M.cString, "$6$", M.cGroupe+'1')
    M.cString = STRTRAN(M.cString, "$7$", M.cGroupe+'2')
    M.cString = STRTRAN(M.cString, "$8$", M.cGroupe+'3')
    M.cString = STRTRAN(M.cString, "$9$", M.cGroupe+'4')
ENDFOR

** Remplacer les S par des Z s’ils sont précédés et suivis
** des lettres a, e, i, o, u, y ou d’un son 1 à 4

M.cResultat = LEFT(M.cString,1)
FOR I = 2 TO LEN(M.cString)-1
    M.cLettre = SUBSTR(M.cString, I, 1)
    IF M.cLettre = 'S' AND ;
       AT(RIGHT(M.cResultat,1), "AEIOUY1234") > 0 AND ;
       AT(SUBSTR(M.cString, I+1, 1), "AEIOUY1234") > 0
       M.cResultat = M.cResultat + 'Z'
    ELSE
       M.cResultat = M.cResultat + M.cLettre
    ENDIF
ENDFOR
M.cResultat = M.cResultat + RIGHT(M.cString,1)

** Remplacer les groupes de 2 lettres suivants

M.cResultat = STRTRAN(M.cResultat, "OE"'E')
M.cResultat = STRTRAN(M.cResultat, "EU"'E')
M.cResultat = STRTRAN(M.cResultat, "AU"'O')
M.cResultat = STRTRAN(M.cResultat, "OI"'2')
M.cResultat = STRTRAN(M.cResultat, "OY"'2')
M.cResultat = STRTRAN(M.cResultat, "OU"'3')

** remplacer les groupes de lettres suivants

M.cResultat = STRTRAN(M.cResultat, "CH"'5')
M.cResultat = STRTRAN(M.cResultat, "SCH"'5')
M.cResultat = STRTRAN(M.cResultat, "SH"'5')
M.cResultat = STRTRAN(M.cResultat, "SS"'S')
M.cResultat = STRTRAN(M.cResultat, "SC"'S')


** Remplacer les lettres ou groupe de lettres suivants

M.cResultat = STRTRAN(M.cResultat, "QU"'K')
M.cResultat = STRTRAN(M.cResultat, "GU"'K')
M.cResultat = STRTRAN(M.cResultat, "GA""KA")
M.cResultat = STRTRAN(M.cResultat, "GO""KO")
M.cResultat = STRTRAN(M.cResultat, "GY""KY")
M.cResultat = STRTRAN(M.cResultat, "G1""K1")
M.cResultat = STRTRAN(M.cResultat, "G2""K2")
M.cResultat = STRTRAN(M.cResultat, "G3""K3")

** Remplacer les lettres suivantes :

M.c1="CQDJBVM"
M.c2="KKTGPFN"

M.cResultat = CHRTRAN(M.cResultat, M.c1, M.c2)

** Supprimer les lettres dupliquées

M.cString = M.cResultat
M.cLettre = LEFT(M.cString, 1)
M.cResultat = M.cLettre
FOR I = 2 TO LEN(M.cString)
    M.cCar = SUBSTR(M.cString, I, 1)
    IF M.cCar <> M.cLettre
       M.cLettre = M.cCar
       M.cResultat = M.cResultat + M.cLettre
    ENDIF
ENDFOR

** Supprimer le 'E' final précédant un 'X'
IF RIGHT(M.cResultat,2) = "XE"
   M.cResultat =  LEFT(M.cResultat, LEN(M.cResultat)-1)
ENDIF

** Supprimer les terminaisons suivantes : T, P, X, S, Z
** si elles ne sont pas précédées d'un E
IF LEN(M.cResultat) > 1 AND SUBSTR(M.cResultat, LEN(M.cResultat)-1, 1) <> 'E' AND ;
   INLIST(RIGHT(M.cResultat,1), 'T''P''X''S''Z')
   M.cResultat = LEFT(M.cResultat, LEN(M.cResultat)-1)
ENDIF

RETURN M.cResultat

Commentaires
le 28/02/2007, Francis Faure a écrit :
Excellent !
belle contribution


Publicité

Les pubs en cours :


www.atoutfox.org - Site de la Communauté Francophone des Professionnels FoxPro - v3.4.0 - © 2004-2019.
Cette page est générée par un composant COM+ développé en Visual FoxPro 9.0-SP2-HF3