Salut.
Code : Tout sélectionner
;****************************************
;*soundex2 francisé par Frédéric BROUARD*
;****************************************
;Version Purebasic : Comtois
;Date : 21/04/04
; PB version : 3.81 fonctionne avec PB4.50
; Librairies extérieures utilisées : Aucune
;Categories : Algorithmes / Soundex
;Le principe
;Comment dans une liste de nom de personne arriver à retrouver un certain DUPONT ou DUPOND ou DUPAN ou encore DEPAIN ???
;C'est simple, il suffit de se baser sur la consonance et non sur les mots eux-mêmes.
;Tous les algorithmes de Soundex reposent sur un principe de base qui consiste à codifier Le Mot en éliminant les lettres en doubles,
;les lettres muettes (H en particulier) et en rapprochant les sons de certaines lettres.
;une fois cette codification obtenue on la stocke auprès de la donnée de base et on effectue la recherche par comparaison directe
;entre Le Soundex</span> ainsi obtenu et Le Mot recherché codifié lui aussi en <span class="posthilit">Soundex.
;Pour en savoir plus , faites un tour sur le site de Frédéric BROUARD
;http://sqlpro.developpez.com/Soundex/SQL_AZ_soundex.html
Global Dim Voyelle.s(4)
Global Dim Combin1.s(11,2)
Global Dim Combin2.s(5,2)
;voyelles
For A=1 To 4
Read$ Voyelle(A)
Next A
;Combi1
For A=1 To 11
For b=1 To 2
Read$ Combin1(A,b)
Next b
Next A
;Combi2
For A=1 To 5
For b=1 To 2
Read$ Combin2(A,b)
Next b
Next A
Procedure.s prepare(sIn.s)
; 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 R en lettre équivalent en majuscules normales
Define.l tailleSin
Define.s car,sOut
; mise en majuscule
sIn=Trim(sIn) : sIn=UCase(sIn) : tailleSin=Len(sIn)
sOut =""
For i=1 To tailleSin
car=Mid(sIn,i,1)
If car="Â" Or car="Ä" Or car="À"
car ="A"
ElseIf car="Ç"
car="S"
ElseIf car="È" Or car="É" Or car="Ê" Or car="Ë" Or car="R"
car="E"
ElseIf car="Î" Or car="Ï"
car="I"
ElseIf car="Ô" Or car="Ö"
car="O"
ElseIf car="Ù" Or car="Û" Or car="Ü"
car="U"
EndIf
sOut=sOut+car
Next i
; suppression des blancs et des tirets
sIn=sOut : sOut=""
For i=1 To Len(sIn)
car=Mid(sIn,i,1)
If (car <> " ") And (car <> "-")
sOut=sOut+car
EndIf
Next i
ProcedureReturn sOut
EndProcedure
Procedure.s soundex2(sIn.s)
Define.l i,lSin
Define.s prfx,let,sIn2
; cas trivial : la chaîne est vide
If sIn=""
ProcedureReturn " "
EndIf
; on prepare la chaine : étapes 1, 2 et 3
sIn=prepare(sIn)
lSin=Len(sIn)
; traitement du second effet de bord : chaîne de longeur 1
If lSin=1
ProcedureReturn sIn+" "
EndIf
;/étape 5 : on remplace les consonnances primaires
For i=1 To 11
sIn=ReplaceString(sIn,Combin1(i,1),Combin1(i,2))
Next i
;/étape 6 : on remplace les voyelles sauf le Y et sauf la première par A
lSin=Len(sIn)
sIn2= Right(sIn,lSin-1)
For i=1 To 4
sIn2=ReplaceString(sIn2,Voyelle(i),"A")
Next i
sIn=Left(sIn,1)+sIn2
;/étape 7 : on remplace les préfixes
lSin=Len(sIn)
If lSin>=2
prfx=Left(sIn,2)
EndIf
If prfx="KN"
prfx="NN"
EndIf
If prfx="PH" Or prfx="PF"
prfx="FF"
EndIf
If lSin=2
sIn=prfx
Else
sIn=prfx+Right(sIn,lSin-2)
EndIf
If lSin>=3
prfx=Left(sIn,3)
EndIf
If prfx="MAC"
prfx="MCC"
EndIf
If prfx="SCH"
prfx="SSS"
EndIf
If prfx="ASA"
prfx="AZA"
EndIf
If lSin=3
sIn=prfx
Else
sIn=prfx+Right(sIn,lSin-3)
EndIf
;/ étape 8 : on conserve la première lettre et on fait les remplacements complémentaires
sIn2=Right(sIn,lSin-1)
For i=1 To 5
sIn2=ReplaceString(sIn2,Combin2(i,1),Combin2(i,2))
sIn=Left(sIn,1)+sIn2
Next i
;/étape 9 : suppression des H sauf CH ou SH
lSin=Len(sIn)
sIn2=""
For i=1 To lSin
; pas de H on conserve la lettre
If Mid(sIn,i,1)<>"H"
sIn2=sIn2+Mid(sIn,i,1)
Else
; le H est précédé d'un S ou d'un c on le conserve
If (i>1) And ((Mid(sIn,i-1,1)="C") Or (Mid(sIn,i-1,1)="S"))
sIn2=sIn2+Mid(sIn,i,1)
EndIf
EndIf
Next i
sIn=sIn2
;/étape 10 : suppression des Y sauf précédés d'un A
lSin=Len(sIn)
sIn2=""
For i=1 To lSin
; pas de Y on conserve la lettre
If Mid(sIn,i,1)<>"Y"
sIn2=sIn2+Mid(sIn,i,1)
Else
; le Y est précédé d'un A on le conserve
If i>1 And Mid(sIn,i-1,1)="C"
sIn2=sIn2+Mid(sIn,i,1)
EndIf
EndIf
Next i
sIn=sIn2
;/étape 11 : on supprime les terminaisons A, T, d, s
lSin=Len(sIn)
let=Right(sIn,1)
If let="A" Or let="D" Or let="S" Or let="T"
sIn=Left(sIn,lSin-1)
EndIf
;/étape 12 : suppression de tous les A sauf en Tête
lSin=Len(sIn)
sIn2=Left(sIn,1)
For i=2 To lSin
; pas de A on conserve la lettre
If Mid(sIn,i,1) <> "A"
sIn2=sIn2+Mid(sIn,i,1)
EndIf
Next i
sIn=sIn2
;/étape 13 : on supprime les lettres répétitives
lSin=Len(sIn)
sIn2.s=""
For i=1 To lSin
car.s=Mid(sIn,i,1)
If FindString(sIn2,Mid(sIn,i,1),1)=0
sIn2=sIn2+car
EndIf
Next i
sIn=sIn2
;/étape 14 : on ne retient que 4 caractères ou on complète avec des blancs
sIn=Left(LSet(sIn,4 ," "),4)
ProcedureReturn sIn
EndProcedure
;Tests
a$="Bidouille" : Debug a$+ "=>"+soundex2(a$) ; code = BDL
a$="Bydouile" : Debug a$+ "=>"+soundex2(a$) ; code = BDL
a$="Byddouyle" : Debug a$+ "=>"+soundex2(a$) ; code = BDL
a$="Bi douile" : Debug a$+ "=>"+soundex2(a$) ; code = BDL
a$="Bi douile" : Debug a$+ "=>"+soundex2(a$) ; code = BDL
a$="Bi dooil" : Debug a$+ "=>"+soundex2(a$) ; code = BDL
a$="Bhidooihl" : Debug a$+ "=>"+soundex2(a$) ; code = BDL
Debug "-------------------------------"
a$="Faure" : Debug a$+ "=>"+soundex2(a$) ; code = FR
a$="Fort" : Debug a$+ "=>"+soundex2(a$) ; code = FR
a$="phaure" : Debug a$+ "=>"+soundex2(a$) ; code = FR
a$="Feaure" : Debug a$+ "=>"+soundex2(a$) ; code = FR
a$="Faure" : Debug a$+ "=>"+soundex2(a$) ; code = FR
a$="Fort" : Debug a$+ "=>"+soundex2(a$) ; code = FR
a$="phaurre" : Debug a$+ "=>"+soundex2(a$) ; code = FR
a$="Fhaure" : Debug a$+ "=>"+soundex2(a$) ; code = FR
End
;-
DataSection
;Voyelles
Data.s "E","I","O","U"
;Combin1
Data.s "GUI","KI"
Data.s "GUE","KE"
Data.s "GA","KA"
Data.s "GO","KO"
Data.s "GU","K"
Data.s "CA","KA"
Data.s "CO","KO"
Data.s "CU","KU"
Data.s "Q","K"
Data.s "CC","K"
Data.s "CK","K"
;combin2
Data.s "ASA","AZA"
Data.s "KN","NN"
Data.s "PF","FF"
Data.s "PH","FF"
Data.s "SCH","SSS"
EndDataSection
, t'es un dieux en PB
et sa va poser problème par la suite 
