PureBasic

Forums PureBasic - Français
http://forums.purebasic.com/french/

LIKE(str1$, str2$) : détection des chaines semblables

http://forums.purebasic.com/french/viewtopic.php?t=3011

Page 1 sur 1

LIKE(str1$, str2$) : détection des chaines semblables

Publié : sam. 11/juin/2005 22:51
par lionel_om
Bonjour à tous.
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
Plus la valeur des paramètres est élevée, moins le programme est strict sur les comparaison et donc plus les chaines auront de chances d'être considérées comme semblables.

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 !!! :P

A++

Publié : mer. 15/juin/2005 9:03
par lionel_om
Malgré que ça n'a pas l'air d'intéresser grand monde, je reposte un deuxième code, mais celui-ci plus performant...

Il permet en effet de repérer les cycles de chaines et donc d'affecter en plus un coefficient de décalage des lettres dans la chaine.

Ce système est beacoup plus performant que le précédent.

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
;#PI       = 3.1415916


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.5
  opt\SW_Letters  = 0.3
  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
  
  If pourc<0
    ProcedureReturn (#FALSE)
  EndIf
  
  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, temp2.w
  Protected swap$, i.w, j.b, num.w, denum.w, rapp.f, rap2.f
  
  ; 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
    
  If Len(s1) > Len(s2)
    swap$ = s1: s1 = s2 : s2 = swap$
  EndIf
    
  
  ; Test sur le nombre de lettres

  If LikeFonction((Len(s1) * 1.0)/Len(s2), Len(s2), *opt\Size, *opt\SW_Size, #RET_INT) = #False
    ; Debug " . Nombre de lettres trop éloigné"
    If FindString(s2,s1,1)
      ProcedureReturn(LikeFonction(Len(s1)*1.2/Len(s2), Len(s2), *opt\Letters, *opt\SW_Letters, #RET_MAX))
    Else
      ProcedureReturn(#FALSE)
    EndIf
  EndIf
  
  
  ; Test sur la recherche de mini-chaines
  ; Debug s1 + "; " + s2
  
  If Len(s1)<4
  
    ; S'il y a a peu de lettres, on recherche les lettres communes
    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
    
    rapp = (found_s1 * 1.0)/found_s2
    
    ; Debug LikeFonction(rapp, found_s2, *opt\Letters, *opt\SW_Letters, #RET_REEL)
    ProcedureReturn(LikeFonction(rapp, found_s2, *opt\Letters, *opt\SW_Letters, #RET_MAX))
    
  Else
  
    ; Sinon on recherche des occurances de 2 à Len-1 lettres
    temp  = 0     : temp2 = 0
    decal = 0     : nbDec = 0
    s1 = s1 + s1  : s2 = s2 + s2
    
    For i = 2 To 3
      For j = 1 To (Len(s1)/2)
        swap$ = Mid(s1, j, i)
        found_s2 = CountString(s2, swap$)
        temp2 + 1
        If found_s2
          found_s1 = CountString(s1, swap$) - 1
          temp = temp + (found_s2 - found_s1)
          decal + Abs(FindString(s2, swap$, j-2) - j)
          nbDec + 1
        EndIf
      Next j
      
    Next i
    
    If nbDec>0 And decal>0
      If nbDec < decal
        rapp = Pow( (decal*1.0)/nbDec, 2)/10.0
      Else
        rapp = 0.05
      endif
    Else
      rapp = 0
    EndIf
    
    found_s1 = (temp2 - temp) / 5
    rap2 = ( (Len(s1) - found_s1) / (Len(s2)*1.0) ) - ( (temp2 -(temp + found_s1 * 5))/(Len(s2)*0.7) )
    rap2 - rapp
    
    ; Debug LikeFonction(rap2, Len(s2), *opt\Letters, *opt\SW_Letters, #RET_REEL)
    ProcedureReturn LikeFonction(rap2, Len(s2), *opt\Letters, *opt\SW_Letters, #RET_MAX)
    
  EndIf

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 = ReplaceString(Trim(s1.s), "  ", " ")
  s2.s = ReplaceString(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

Publié : mer. 22/juin/2005 11:49
par ZapMan
Moi, ça m'intéresse beaucoup !

Je veux dire par là que je garde bien au chaud le résultat de ton travail. Je n'ai pas le temps de m'y pencher pour le moment, mais c'est un outil trés intéressant pour les contrôles de saisie (recherche d'un nom dans une base, par exemple)

Merci d'avoir partagé.

Publié : mer. 22/juin/2005 16:56
par comtois
ZapMan a écrit :(recherche d'un nom dans une base, par exemple)
pour ça , tu as aussi l'algo soundex

http://purebasic.hmt-forum.com/viewtopi ... ht=soundex

Publié : jeu. 23/juin/2005 0:43
par ZapMan
Les deux ensemble, ça peut faire trés fort ! :D

Publié : dim. 03/juil./2005 9:40
par lionel_om
Sympa la méthode SoundEx, par contre elle comporte pas mal d'inconvéniants :
* Problème sur les mots trops longs (car juste 4 consonnes sont gardées, en schématisant)
* Test plutot sur la prononciation des lettres plutot quer l'ortographe, donc valable en français mais pas forcément en anglais.

Mais sinon c'est vrai que cette méthode est intéressante.
Fuseau horaire sur UTC+01:00
Page 1 sur 1

Développé par phpBB® Forum Software © phpBB Limited

Traduction française officielle © Qiaeru