Comment trouver une position d'une sous-chaîne dans une chaîne avec une correspondance floue

Question

J'ai rencontré un problème d'appariement d'une chaîne dans un texte reconnu OCR et trouvé sa position en considérant qu'il peut y avoir une tolérance arbitraire de faux, manquants ou supplémentaires personnages. Le résultat devrait être une meilleure position de correspondance, éventuellement (pas nécessairement) avec la longueur de la sous-chaîne correspondante.

Par exemple:

String: 9912, 1.What is your name? 
Substring: 1. What is your name? 
Tolerance: 1 
Result: match on character 7 

String: Where is our caat if any? 
Substring: your cat 
Tolerance: 2 
Result: match on character 10 

String: Tolerance is t0o h1gh. 
Substring: Tolerance is too high; 
Tolerance: 1 
Result: no match 

J'ai essayé d'adapter l'algorithme Levenstein, mais il ne fonctionne pas correctement pour et ne retourne substrings pas de position.

L'algorithme de Delphi serait préféré, mais toute implémentation ou pseudo logique le ferait.

Answer 1

Voici une implémentation récursive qui fonctionne, mais peut-être pas assez rapide. Le pire des cas est quand une correspondance ne peut être trouvée, et tous sauf le dernier caractère dans "Quoi" est mis en correspondance à chaque index dans Où. Dans ce cas, l'algorithme effectuera des comparaisons de longueur (What) -1 + Tolérance pour chaque caractère dans Where, plus un appel récursif par Tolérance. Comme Tolerance et la longueur de What sont constnats, je dirais que l'algorithme est O (n). Ses performances se dégradent linéairement avec la longueur de "Quoi" et "Où".

function BrouteFindFirst(What, Where:string; Tolerance:Integer; out AtIndex, OfLength:Integer):Boolean; 
    var i:Integer; 
     aLen:Integer; 
     WhatLen, WhereLen:Integer; 

    function BrouteCompare(wherePos, whatPos, Tolerance:Integer; out Len:Integer):Boolean; 
    var aLen:Integer; 
     aRecursiveLen:Integer; 
    begin 
     // Skip perfect match characters 
     aLen := 0; 
     while (whatPos <= WhatLen) and (wherePos <= WhereLen) and (What[whatPos] = Where[wherePos]) do 
     begin 
     Inc(aLen); 
     Inc(wherePos); 
     Inc(whatPos); 
     end; 
     // Did we find a match? 
     if (whatPos > WhatLen) then 
     begin 
      Result := True; 
      Len := aLen; 
     end 
     else if Tolerance = 0 then 
     Result := False // No match and no more "wild cards" 
     else 
     begin 
      // We'll make an recursive call to BrouteCompare, allowing for some tolerance in the string 
      // matching algorithm. 
      Dec(Tolerance); // use up one "wildcard" 
      Inc(whatPos); // consider the current char matched 
      if BrouteCompare(wherePos, whatPos, Tolerance, aRecursiveLen) then 
      begin 
       Len := aLen + aRecursiveLen; 
       Result := True; 
      end 
      else if BrouteCompare(wherePos + 1, whatPos, Tolerance, aRecursiveLen) then 
      begin 
       Len := aLen + aRecursiveLen; 
       Result := True; 
      end 
      else 
      Result := False; // no luck! 
     end; 
    end; 

    begin 

    WhatLen := Length(What); 
    WhereLen := Length(Where); 

    for i:=1 to Length(Where) do 
    begin 
     if BrouteCompare(i, 1, Tolerance, aLen) then 
     begin 
     AtIndex := i; 
     OfLength := aLen; 
     Result := True; 
     Exit; 
     end; 
    end; 

    // No match found! 
    Result := False; 

    end; 

Je l'ai utilisé le code suivant pour tester la fonction:

procedure TForm18.Button1Click(Sender: TObject); 
var AtIndex, OfLength:Integer; 
begin 
    if BrouteFindFirst(Edit2.Text, Edit1.Text, ComboBox1.ItemIndex, AtIndex, OfLength) then 
    Label3.Caption := 'Found @' + IntToStr(AtIndex) + ', of length ' + IntToStr(OfLength) 
    else 
    Label3.Caption := 'Not found'; 
end; 

Pour le cas:

String: Where is our caat if any? 
Substring: your cat 
Tolerance: 2 
Result: match on character 10 

il montre un match sur le caractère 9, de longueur 6. Pour la deux autres exemples, il donne le résultat attendu.