iBase.ru Forum

Код: Выделить всё

declare external function IndistinctMatching
smallint, cstring(254), cstring(254)
returns smallint by value
entry_point 'udf_IndistinctMatching' module_name 'udfIndistinctMatching';

declare external function IndistinctMatching3
cstring(254), cstring(254)
returns smallint by value
entry_point 'udf_IndistinctMatching3' module_name 'udfIndistinctMatching';

declare external function IndistinctMatching4
cstring(254), cstring(254)
returns smallint by value
entry_point 'udf_IndistinctMatching4' module_name 'udfIndistinctMatching';

declare external function IndistinctMatchingEx
smallint, cstring(254), cstring(254)
returns smallint by value
entry_point 'udf_IndistinctMatchingEx' module_name 'udfIndistinctMatching';

declare external function IndistinctMatchingEx3
cstring(254), cstring(254)
returns smallint by value
entry_point 'udf_IndistinctMatchingEx3' module_name 'udfIndistinctMatching';

declare external function IndistinctMatchingEx4
cstring(254), cstring(254)
returns smallint by value
entry_point 'udf_IndistinctMatchingEx4' module_name 'udfIndistinctMatching';

Код: Выделить всё

{$SOPREFIX ''}
library udfIndistinctMatching;

uses
  FindCompare, RegExpr, SysUtils;

function Normalize(s: String): String;
var
  regexpr: TRegExpr;
begin
  regexpr := TRegExpr.Create;
  try
    with regexpr do
      begin
        ModifierI := True;
        ModifierR := True;

        Expression := '[^a-zA-Z└-▀р- и╕0-9]';
        s := Replace(s, '', True);

        Expression := '(.)\1+';
        s := Replace(s, '$1', True);
      end;
  finally
    regexpr.Free;
  end;
  Result := AnsiUpperCase(s);
end;

function udf_IndistinctMatching(MaxMatching: SmallInt; strInputMatching, strInputStandart: PChar): SmallInt; cdecl; export;
begin
  Result := IndistinctMatching(MaxMatching, strInputMatching, strInputStandart);
end;

function udf_IndistinctMatching3(strInputMatching, strInputStandart: PChar): SmallInt; cdecl; export;
begin
  Result := IndistinctMatching(3, strInputMatching, strInputStandart);
end;

function udf_IndistinctMatching4(strInputMatching, strInputStandart: PChar): SmallInt; cdecl; export;
begin
  Result := IndistinctMatching(4, strInputMatching, strInputStandart);
end;

(*
################################################################################
### Normalize
################################################################################
*)
function udf_IndistinctMatchingEx(MaxMatching: SmallInt; strInputMatching, strInputStandart: PChar): SmallInt; cdecl; export;
begin
  strInputMatching := PChar( Normalize(strInputMatching) );
  strInputStandart := PChar( Normalize(strInputStandart) );
  Result := IndistinctMatching(MaxMatching, strInputMatching, strInputStandart);
end;

function udf_IndistinctMatchingEx3(strInputMatching, strInputStandart: PChar): SmallInt; cdecl; export;
begin
  strInputMatching := PChar( Normalize(strInputMatching) );
  strInputStandart := PChar( Normalize(strInputStandart) );
  Result := IndistinctMatching(3, strInputMatching, strInputStandart);
end;

function udf_IndistinctMatchingEx4(strInputMatching, strInputStandart: PChar): SmallInt; cdecl; export;
begin
  strInputMatching := PChar( Normalize(strInputMatching) );
  strInputStandart := PChar( Normalize(strInputStandart) );
  Result := IndistinctMatching(4, strInputMatching, strInputStandart);
end;

exports
  udf_IndistinctMatching,
  udf_IndistinctMatching3,
  udf_IndistinctMatching4,
  udf_IndistinctMatchingEx,
  udf_IndistinctMatchingEx3,
  udf_IndistinctMatchingEx4;

begin

end.

Код: Выделить всё

unit FindCompare;

interface

//------------------------------------------------------------------------------
//Функция нечеткого сравнения строк БЕЗ УЧЕТА РЕГИСТРА
//------------------------------------------------------------------------------
//MaxMatching - максимальная длина подстроки (достаточно 3-4)
//strInputMatching - сравниваемая строка
//strInputStandart - строка-образец

// Сравнивание без учета регистра
// if IndistinctMatching(4, "поисковая строка", "оригинальная строка  - эталон") > 40 then ...

function IndistinctMatching(MaxMatching     : Integer;
                            strInputMatching: WideString;
                            strInputStandart: WideString): Integer;
implementation

Uses SysUtils;

Type
     TRetCount = packed record
                 lngSubRows   : Word;
                 lngCountLike : Word;
                end;

//------------------------------------------------------------------------------
function Matching(StrInputA: WideString;
                  StrInputB: WideString;
                  lngLen: Integer) : TRetCount;
Var
    TempRet   : TRetCount;
    PosStrB   : Integer;
    PosStrA   : Integer;
    StrA      : WideString;
    StrB      : WideString;
    StrTempA  : WideString;
    StrTempB  : WideString;
begin
    StrA := String(StrInputA);
    StrB := String(StrInputB);

    For PosStrA:= 1 To Length(strA) - lngLen + 1 do
    begin
       StrTempA:= System.Copy(strA, PosStrA, lngLen);

       PosStrB:= 1;
       For PosStrB:= 1 To Length(strB) - lngLen + 1 do
       begin
          StrTempB:= System.Copy(strB, PosStrB, lngLen);
          If SysUtils.AnsiCompareText(StrTempA,StrTempB) = 0 Then
          begin
             Inc(TempRet.lngCountLike);
             break;
          end;
       end;

       Inc(TempRet.lngSubRows);
    end; // PosStrA

    Matching.lngCountLike:= TempRet.lngCountLike;
    Matching.lngSubRows  := TempRet.lngSubRows;
end; { function }

//------------------------------------------------------------------------------
function IndistinctMatching(MaxMatching     : Integer;
                            strInputMatching: WideString;
                            strInputStandart: WideString): Integer;
Var
    gret     : TRetCount;
    tret     : TRetCount;
    lngCurLen: Integer   ; //текущая длина подстроки
begin
    //если не передан какой-либо параметр, то выход
    If (MaxMatching = 0) Or (Length(strInputMatching) = 0) Or
       (Length(strInputStandart) = 0) Then
    begin
        IndistinctMatching:= 0;
        exit;
    end;

    gret.lngCountLike:= 0;
    gret.lngSubRows  := 0;
    // Цикл прохода по длине сравниваемой фразы
    For lngCurLen:= 1 To MaxMatching do
    begin
        //Сравниваем строку A со строкой B
        tret:= Matching(strInputMatching, strInputStandart, lngCurLen);
        gret.lngCountLike := gret.lngCountLike + tret.lngCountLike;
        gret.lngSubRows   := gret.lngSubRows + tret.lngSubRows;
        //Сравниваем строку B со строкой A
        tret:= Matching(strInputStandart, strInputMatching, lngCurLen);
        gret.lngCountLike := gret.lngCountLike + tret.lngCountLike;
        gret.lngSubRows   := gret.lngSubRows + tret.lngSubRows;
    end;

    If gret.lngSubRows = 0 Then
    begin
        IndistinctMatching:= 0;
        exit;
    end;

    IndistinctMatching:= Trunc((gret.lngCountLike / gret.lngSubRows) * 100);
end;


end.