FONCTION RENVOYANT LE POURCENTAGE DE SIMILITUDE ENTRE 2 CHAINES

// ----------------------------------------------------------------------------------------
Function ComparerChaines(s1,s2:String):Integer;
{ Fonction comparaison chaînes de texte:
  Entrée:
    S1 = première chaîne a comparer, taille limitée a 2048 caractères
    S2 = deuxième chaîne a comparer, taille limitée a 2048 caractères
  Sortie:
    INTEGER, de 0 a 100, % de ressemblance entre les 2 chaînes }
Var identiques,                        // Nombre de caractères identiques
    p1,p2,                             // Indicateurs de position
    l1,l2,                             // Longueurs des chaînes
    pt,                                // Compteur de boucle
    diff : Integer;                    // Facteur d égalisation
    hstr : String;                     // Variable temporaire d échange des chaînes
    test : Array [1..2048] Of Boolean; // Tableau d indicateur pour suivre les positions déjà testées
Begin
  // Tester les longueurs et échanger si S1 est plus courte, on teste toujours par rapport a la chaîne la plus longue
  If Length(s1)<Length(s2) Then Begin
    hstr := s2;
    s2   := s1;
    s1   := hstr;
  End;
  // Stocker les longueurs des chaînes
  l1 := Length(s1);
  l2 := Length(s2);
  // Une chaîne a vide ? alors la comparaison est de 0%
  If (l1=0) Or (l2=0) Then
    Result := 0
  Else Begin
    p1         := 1;
    p2         := 1;
    identiques := 0;
    // Calculer le facteur d égalisation dépendant de la longueur de la chaîne, en général c est 1/3 de la longueur maximale
    diff       := Max(l1,l2) Div 3 + Abs(l1-l2);
    // Initialiser le tableau de suivi
    For pt := 1 To l1 Do
      test[pt] := False;
    // Parcours de la chaîne
    Repeat
      // Position testée ?
      If Not test[p1] Then Begin
        // Caractère identique ?
        If (s1[p1]=s2[p2]) And (Abs(p1-p2)<=diff) Then Begin
          test[p1] := True;
          // Augmenter le compteur de caractères identiques
          Inc(identiques);
          // Positions suivantes
          Inc(p1);
          Inc(p2);
          // Boucler
          If p1>l1 Then p1:=1;
        End Else Begin
          Test[p1] := False;
          Inc(p1);
          // Boucler a la prochaine position de test si on arrive a la fin de la chaîne
          If p1>l1 Then Begin
            While (p1>1) And Not (test[p1]) Do
              Dec(p1);
            Inc(p2)
          End;
        End;
      End Else Begin
        Inc(p1);
        // Boucler a la prochaine position de test si on arrive a la fin de la chaîne
        If p1>l1 Then Begin
          Repeat
            Dec(p1);
          Until (p1=1) Or test[p1];
          Inc(p2);
        End;
      End;
    Until p2>Length(s2);
    // Calculer la valeur en pourcentage
    Result := 100 * identiques Div l1;
  End;
End;