J'ai passé mon aprem (et mm ma soirée vu l'h) à faire une fonction qui ressemble à la fonction SQl : LIKE.
Cette fonction renvoi VRAI si les deux chaines passée en paramètres sont semblables. Je crois pas que cette fonction existe en PB, ya que la fonction d'égalité.
Graâce à une structure (passée en paramètre), on peut faire varier les paramètres de la fonction pour calculer les ressemblances.
Voici mon code avec un exemple :
Code : Tout sélectionner
Structure LikeData
; CaseSensitive (0 = insensible)
Sensitive.b
; Max Ascii Caractère search (ne pas remplir !!!)
MaxAsc.w
; Pour la taille des mots
Size.f ; coef général
SW_Size.f ; coef pour aider les petits mots
; Pour la ressemblance des mots
Letters.f ; coef général
SW_Letters.f ; coef pour aider les petits mots
; Pour le nombre de mots similaires
Word.f ; coef général
SW_Word.f ; coef pour aider les phrases avec peu de mots
EndStructure
#RET_INT = 0
#RET_REEL = 1
#RET_MAX = 2
Declare.b Like(s1.s, s2.s, *opt.LikeData)
Declare.f LikeWord(s1.s, s2.s, *opt.LikeData)
Declare.f LikeFonction(pour.f, taille.w, coef1.f, coef2.f, reel.b)
opt.LikeData
opt\sensitive = 0
opt\Size = 2.0
opt\SW_Size = 1.0
opt\Letters = 1.17
opt\SW_Letters = 0.8
opt\Word = 2.0
opt\SW_Word = 1.0
nbData.b
Restore donnees
Read nbData
For i = 1 To nbData
Read ch1$
Read ch2$
; on remplace les '-' et les '_' par des ' '
ReplaceString(s1$, "_", " ",2)
ReplaceString(s2$, "_", " ",2)
ReplaceString(s1$, "-", " ",2)
ReplaceString(s2$, "-", " ",2)
Debug " "
Debug "LIKE : '" + ch1$ + "', '" + ch2$ + "'"
If Like(ch1$, ch2$, @opt)
Debug " >> OK !"
Else
Debug " >> NOOOOON !"
EndIf
Next i
DataSection
donnees:
Data.b 10
Data.s "NightWish Ocean Born", "Nightwish ocean born"
Data.s "Salut ca va ?", "salut ca va"
Data.s "Ma souris va bien", "ta souris va bien"
Data.s "Je vais bien dormir", "Tu vas bien dormir"
Data.s "Je v tester ceci", "je t jetter ceci"
; avec un nb de mot différent
Data.s "Salut je vais a l'école", "Balut tu vas à l'école"
Data.s "Je vais au collège", "Je vais au lycée"
Data.s "Tu es bete", "Je suis bete"
Data.s "Pure basic est super", "Dark Basic est perdu"
Data.s "Ces chaines sont semblables", "Ses Chaises vont ensembles"
EndDataSection
; -_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
; | |
;- les Fonctions |
; | |
; _-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
; Fonction dont le résultat est variable via les paramètres de la structure de type : LikeData
Procedure.f LikeFonction(pourc.f, taille.w, coef1.f, coef2.f, reel.b)
Protected r.f
r = Pow(1+(pourc/2.3), coef1) + (#PI/2)-ATan(taille/coef2) - 1
Select reel
Case #RET_INT
If r >= 1.0
r = #True
Else
r = #FALSE
EndIf
Case #RET_MAX
If r > 1.0
r = #True
EndIf
EndSelect
ProcedureReturn(r)
EndProcedure
; Compare deux mots et renvoi VRAi s'ils sont semblables
Procedure.f LikeWord(s1.s, s2.s, *opt.LikeData)
Protected found_s1.w, found_s2.w, temp.w, rapport.w
; Debug " Comparaison de '" + s1 + "' et de '" + s2 +"'"
s1 = Trim(s1)
s2 = Trim(s2)
If s1 = s2
; Debug " . Ces mots sont les mm"
ProcedureReturn(#TRUE)
EndIf
If Len(s1) = 0 Or Len(s2) = 0
; Debug " . Une chaine est vide"
ProcedureReturn(#FALSE)
EndIf
; Test sur le nombre de lettres
rapport = (Len(s1) * 100)/Len(s2)
If rapport > 100
rapport = 200 - rapport
EndIf
If Len(s1) > Len(s2)
temp = Len(s1)
Else
temp = Len(s2)
EndIf
If LikeFonction(rapport/100.0, temp, *opt\Size, *opt\SW_Size, #RET_INT) = #False
; Debug " . Nombre de lettres trop éloigné"
ProcedureReturn(#FALSE)
EndIf
; Test sur le nombre de chaque lettre
For i=32 To *opt\MaxAsc
temp = CountString(s1, Chr(i))
If temp
found_s1 + temp
found_s2 + CountString(s2, Chr(i))
EndIf
Next i
If found_s1 > found_s2
temp = found_s1
found_s1 = found_s2
found_s2 = temp
EndIf
If found_s1=0
; Debug " Division par zéro... so not similar"
If found_s2 = 1
ProcedureReturn(0.33)
Else
ProcedureReturn(#FALSE)
EndIf
EndIf
rapport = (found_s1 * 100)/found_s2
ProcedureReturn(LikeFonction(rapport/100.0, found_s2, *opt\Letters, *opt\SW_Letters, #RET_MAX))
EndProcedure
; Compare deux chaines de caractères et renvoi vrai si elles sont similaires
Procedure Like(s1.s, s2.s, *opt.LikeData)
Protected val1.w, val2.w, nb1.f, nb2.f, swap$, i.w, j.w
*opt\MaxAsc = 127
s1.s = Trim(s1.s)
s2.s = Trim(s2.s)
; On convertit les chaines en maj si on ignore la case
If *opt\sensitive = 0
s1.s = UCase(s1.s)
s2.s = UCase(s2.s)
*opt\MaxAsc = 96
EndIf
val1 = CountString(s1.s, " ")+1
val2 = CountString(s2.s, " ")+1
nb1 = 0: nb2 = 0
If val1 = val2
For i = 1 To val1
swap$ = StringField(s1, i, " ")
nb1 = nb1 + ((LikeWord(swap$, StringField(s2, i, " "), *opt)) * Len(swap$))
Next i
nb1 = nb1 * val1 / (Len(s1)-(val1-1))
Else
If val1>val2
; on inverse les 2 str et leurs rapports ...
swap$ = s1 : s1 = s2 : s2 = swap$
nb1 = val1 : val1 = val2 : val2 = nb1
nb1 = 0
EndIf
For i = 0 To val2-val1
nb2 = 0
For j = 1 To val1
swap$ = StringField(s1, j+i, " ")
nb2 + (LikeWord(swap$, StringField(s2, j, " "), *opt) * Len(swap$))
Next j
nb2 = nb2 * val1 / (Len(s1)-(val1-1))
If nb2>nb1
nb1 = nb2
EndIf
Next i
EndIf
Debug LikeFonction((nb1)/val2, val1, *opt\Word, *opt\SW_Word, #RET_REEL)
ProcedureReturn(LikeFonction((nb1)/val2, val1, *opt\Word, *opt\SW_Word, #RET_INT))
EndProcedure
Je rejouterais plus tard un test pour comparer réellement l'ordre des lettres dans un même mot, car pour l'instant "SALUT" et "LUTSA" sont considérés comme semblables.
La recherche s'effectue sur
* le nombre de lettres des mots (pas de la chaine entières mais des différents mots découpés)
* les lettres trouvés
* l'ordenacement et la similitude des mots des strings...
Voilà, vos remarques sont la bienvenue !!!
A++
