Algorithmes sur chaînes de caractères

[Octavius]

J'ai déjà posté des choses à propos de la distance de Levenshtein et d'autres codes dispersés sur les chaînes de caractères. Je voulais écrire un code qui résumait ces qqs algorithmes intéressants pour manipuler les chaînes. Le code est fourné avec qqs exemples.

- FindLD (Levenshtein-Distance) : trouver la distance d'édition de Levenshtein, si le paramètre #Damerau est précisé, alors la fonction trouvera la distance d'édition de Damerau-Levenshtein (prise en compte des inversions de lettres). J'ai aussi prévu le cas où vous voudriez préciser la sensibilité à la casse (#Case_Insensitive), les deux peuvent être combinés binairement (#Case_Insensitive|#Damerau).
- FindLCS (Longest Common Subsequence) : trouver la plus longue sous-séquence commune (trouve les caractères qui sont en commun dans le même ordre dans les deux chaines de caractères, comme une sorte de PGCD )
- FindSCS (Shortest Common Supersequence) : trouver la plus courte super-séquence commune (pour continuer l'analogie, ce serait une sorte de PPCM !)

Code : Tout sélectionner

EnableExplicit

#Case_Insensitive=1
#Damerau=2

Procedure.i Min(A.i,B.i,C.i)
If A>B : A=B : EndIf
If A>C : A=C : EndIf
ProcedureReturn A
EndProcedure

;Longest Common Subsequence
Procedure.s FindLCS(Text_0.s,Text_1.s)

If Text_0="" Or Text_1="" : ProcedureReturn "" : EndIf

Protected Len_0.i,Len_1.i

Len_0=Len(Text_0)
Len_1=Len(Text_1)

Protected Dim Matrix.s(Len_0+1,Len_1+1)
Protected i.i,j.i

For j=1 To Len_1
  For i=1 To Len_0
    If Mid(Text_0,i,1)=Mid(Text_1,j,1)
      Matrix(i,j)=Matrix(i-1,j-1)+Mid(Text_0,i,1)
    Else
      If Len(Matrix(i,j-1))>Len(Matrix(i-1,j))
        Matrix(i,j)=Matrix(i,j-1)
      Else
        Matrix(i,j)=Matrix(i-1,j)
      EndIf
    EndIf
  Next i
Next j

ProcedureReturn Matrix(Len_0,Len_1)

EndProcedure

;Shortest Common Supersequence
Procedure.s FindSCS(Text_0.s,Text_1.s)

If Text_0="" Or Text_1="" : ProcedureReturn "" : EndIf

Protected Len_0.i,Len_1.i

Len_0=Len(Text_0)
Len_1=Len(Text_1)

Protected Text_LCS.s,Len_LCS.i

Text_LCS=FindLCS(Text_0,Text_1)
Len_LCS=Len(Text_LCS)

;Cas trivial, aucune lettre commune
If Len_LCS=0 : ProcedureReturn Text_0+Text_1 : EndIf

Protected Text_SCS.s,Len_SCS.i,A.i,B.i,C.i,D.i

Len_SCS=Len_0+Len_1-Len_LCS
A=1
B=1
C=1
For D=1 To Len_SCS
  If Mid(Text_0,A,1)=Mid(Text_1,B,1)
    Text_SCS+Mid(Text_LCS,C,1)
    A+1
    B+1
    C+1
  Else
    If Mid(Text_0,A,1)=Mid(Text_LCS,C,1)
      Text_SCS+Mid(Text_1,B,1)
      B+1
    ElseIf Mid(Text_1,B,1)=Mid(Text_LCS,C,1)
      Text_SCS+Mid(Text_0,A,1)
      A+1
    Else
      Text_SCS+Mid(Text_0,A,1)+Mid(Text_1,B,1)
      A+1
      B+1
    EndIf
  EndIf
Next D

ProcedureReturn Text_SCS

EndProcedure

;Levenshtein Distance
Procedure.i FindLD(Text_0.s,Text_1.s,Option.i)

;Identité parfaite, cas trivial
If Text_0=Text_1 : ProcedureReturn 0 : EndIf

Protected Len_0.i,Len_1.i

Len_0=Len(Text_0)
Len_1=Len(Text_1)

If Option & #Case_Insensitive
  Text_0=LCase(Text_0)
  Text_1=LCase(Text_1)
EndIf

;Une des deux chaînes est vide, cas trivial
If Text_0="" : ProcedureReturn Len_1 : ElseIf Text_1="" : ProcedureReturn Len_0 : EndIf

;Matrice pour les calculs
Protected Dim Matrix.i(Len_0+1,Len_1+1)
Protected Dim Cost.i(Len_0,Len_1)
Protected i.i,j.i
Protected Insertion.b,Deletion.b,Substitution.b

;Initialisation de la matrice principale
For i=1 To Len_0 : Matrix(i,0)=i : Next i
For j=1 To Len_1 : Matrix(0,j)=j : Next j

;Remplissage de la matrice secondaire qui détermine les lettres identiques
For i=0 To Len_0-1
  For j=0 To Len_1-1
    If Mid(Text_0,i+1,1)=Mid(Text_1,j+1,1)
      Cost(i,j)=0
    Else
      Cost(i,j)=1
    EndIf
  Next j
Next i

;On remplit la matrice principale
For j=1 To Len_1
  For i=1 To Len_0
    Insertion=Matrix(i-1,j)+1                   ;Insertion
    Deletion=Matrix(i,j-1)+1                    ;Suppression
    Substitution=Matrix(i-1,j-1)+Cost(i-1,j-1)  ;Substitution
    Matrix(i,j)=Min(Insertion,Deletion,Substitution)
    ;Distance de Damerau-Levenshtein
    If Option & #Damerau
      If i>1 And j>1 And Mid(Text_0,i,1)=Mid(Text_1,j-1,1) And Mid(Text_0,i-1,1)=Mid(Text_1,j,1)
        If Matrix(i-2,j-2)+Cost(i-1,j-1)<Matrix(i,j)
          Matrix(i,j)=Matrix(i-2,j-2)+Cost(i-1,j-1) ;Transposition, 4ème comparaison optionnelle
        EndIf
      EndIf
    EndIf
  Next i
Next j

ProcedureReturn Matrix(Len_0,Len_1)

EndProcedure

Debug "Plus longue sous-séquence commune : "+FindLCS("Ceci est une chaîne de caractères !","Cela est une autre chaîne de caractères...")
Debug "Plus courte superséquence commune : "+FindSCS("Ceci est une chaîne de caractères !","Cela est une autre chaîne de caractères...")
Debug ""
Debug "FindLD('niche','chien',0) = "+Str(FindLD("niche","chien",0))
Debug "FindLD('Niche','Chien',0) = "+Str(FindLD("Niche","Chien",0))
Debug "FindLD('Niche','Chien',#Case_Insensitive) = "+Str(FindLD("Niche","Chien",#Case_Insensitive))
Debug ""
Debug "FindLD('mickael','mikcael',0) = "+Str(FindLD("mickael","mikcael",0))
Debug "FindLD('mickael','mikcael',#Damerau) = "+Str(FindLD("mickael","mikcael",#Damerau))

EDIT: A propos de la plus courte superséquence commune, si vous voulez ajouter les lettres non-communes par blocs et non unes à unes, il faut remplacer :

Code : Tout sélectionner

      Text_SCS+Mid(Text_0,A,1)+Mid(Text_1,B,1)
      A+1
      B+1

par :

Code : Tout sélectionner

      Text_SCS+Mid(Text_0,A,1);+Mid(Text_1,B,1)
      A+1
      ;B+1

Vous remarquerez également deux choses :
- La somme des longueurs de la LCS et de la SCS est la même que la somme des longueurs des deux chaînes initiales, le code est d'ailleurs basé en partie sur cette propriété
- Il existe très souvent plusieurs solutions de LCS et de SCS, mais mon code n'en fournit qu'une

[Thyphoon]

merci c'est super interessant ! :