- // ----------------------------------------------------------------------------------------
- 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;
// ----------------------------------------------------------------------------------------
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;