Cómo encontrar una posición de una subcadena dentro de una cadena con coincidencia difusa

Question

Me he encontrado con un problema de coincidencia de una cadena en un texto reconocido OCR y encontrar la posición de ello, ya que puede haber tolerancia arbitraria de incorrecto, falta o extra caracteres. El resultado debería ser una mejor posición de coincidencia, posiblemente (no necesariamente) con la longitud de la subcadena correspondiente.

Por ejemplo:

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 

me han tratado de adaptar el algoritmo Levenstein, pero no funciona correctamente para subcadenas y la posición no vuelve.

Algoritmo en Delphi sería preferible, sin embargo, cualquier implementación o pseudo lógica haría.

Answer 1

Aquí hay una implementación recursiva que funciona, pero que puede no ser lo suficientemente rápida. El peor de los casos es cuando no se puede encontrar una coincidencia, y todos, excepto el último carácter en "Qué", coinciden en cada índice en Dónde. En ese caso, el algoritmo hará las comparaciones Longitud (Qué) -1 + Tolerancia para cada char en Donde, más una llamada recursiva por Tolerancia. Dado que tanto la tolerancia como la duración de What son constnats, diría que el algoritmo es O (n). Su rendimiento se degradará linealmente con la longitud de "Qué" y "Dónde".

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; 

He utilizado el siguiente código para probar la función:

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; 

Para el caso:

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

que muestra un partido en el carácter 9, de longitud 6. Para el otros dos ejemplos da el resultado esperado.