unit LevensteinSuchfunktion;
{
 Einfache Levenstein Distanz
 mit Berücksichtigung von Wildcards
 
 Author: Heinz Josef Lücking 1998
 Lizenz: GNU GPL
}
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
 
type
  TLevensteinSuchfunktion = class(TComponent)
  private
    { Private-Deklarationen }
    FFindeMuster : string;
    FImString : string;
    FFehlerlimit : longint;
    FRechtschreibungstolerant : boolean;
    FAsymetrieausgleich : boolean;
    FErweiterte_Suche : boolean;
    FBeachte_GrossKleinschreibung : boolean;
    FBeachte_1Buchstaben : boolean;
    FMaxVergleich : integer;
    FErgebnis : integer;
    FWeitereZeichenInErweiterteSuche : string;
    procedure SetRechtschreibungstolerant(Value:boolean);
    procedure SetAsymetrieausgleich(Value:boolean);
    procedure SetErweiterte_Suche(Value:boolean);
    procedure SetBeachte_GrossKleinschreibung(Value:boolean);
    procedure SetFindeMuster(Value:string);
    procedure SetImString(Value:string);
    procedure SetWeitereZeichenInErweiterteSuche(Value:string);
  protected
    { Protected-Deklarationen }
    Function WLD : integer;
    Function Min(x,y,z: integer) : integer;
    Function IstohneErwSuchzeichen (Ch: char) : boolean;
  public
    { Public-Deklarationen }
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    Function Execute : boolean;
    Function ExecuteDirect
        (Wort, Muster,weitereZ: string;GK, ErwS, RSchr, Asym: Boolean; Limit: Byte) : boolean;
    Property Ergebnis : integer read FErgebnis ;
  published
    { Published-Deklarationen }
    Property WeitereZeichenInErweiterteSuche : string
      read FWeitereZeichenInErweiterteSuche write SetWeitereZeichenInErweiterteSuche ;
    Property FindeMuster : string
      read FFindeMuster write SetFindeMuster ;
    Property ImString : string
      read FImString write SetImString ;
    Property Fehlerlimit : longint
      read FFehlerlimit write FFehlerlimit default 1;
    Property Rechtschreibungstolerant : boolean
      read FRechtschreibungstolerant write SetRechtschreibungstolerant default true;
    Property Asymetrieausgleich : boolean
      read FAsymetrieausgleich write SetAsymetrieausgleich default false;
    Property Erweiterte_Suche : boolean
      read FErweiterte_Suche write SetErweiterte_Suche default true;
    Property Beachte_GrossKleinschreibung : boolean
      read FBeachte_GrossKleinschreibung write SetBeachte_GrossKleinschreibung default false;
    Property Beachte_1Buchstaben : boolean
      read FBeachte_1Buchstaben write FBeachte_1Buchstaben default false;
    Property MaxVergleich : integer
      read FMaxVergleich write FMaxVergleich default 50;
    Property Name;
    Property Tag;
  end;
 
procedure Register;
 
implementation
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
const maxLen = 50;
 
      ERS1 = 1; {*** Ersetzen ***}
      EIN1 = 1; {*** Einfügen ***}
      DEL1 = 1; {*** Löschen  ***}
 
type  maxString = string[maxLen];
 
var   Wort: String;
      Muster: String;
      lenWort, lenMuster: integer;
      hasWeitereZeichen, hasFindeMuster, hasImString : boolean;
 
constructor TLevensteinSuchfunktion.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
    FFehlerlimit := 1;
    FRechtschreibungstolerant := true;
    FAsymetrieausgleich := false;
    FErweiterte_Suche := true;
    FBeachte_GrossKleinschreibung := false;
    FMaxVergleich := 50;
    hasFindeMuster := false;
    hasImString := false;
 
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
destructor TLevensteinSuchfunktion.Destroy;
begin
  inherited Destroy;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
Function TLevensteinSuchfunktion.Min(x,y,z: integer) : integer;
begin
  if (x < y) then y := x;
  if (y < z) then Min := y else Min := z;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
Function TLevensteinSuchfunktion.IstohneErwSuchzeichen (Ch: char) : boolean;
begin
 if (Ch <> '*') and (Ch <> '?') then IstohneErwSuchzeichen := true
                                else IstohneErwSuchzeichen := false
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
Function TLevensteinSuchfunktion.WLD : integer;
var Ch: char;
    i, j: integer;
    pp,
    Ersetzen,
    Einfuegen,
    Loeschen: integer;
    DistanzArray_1, DistanzArray_2, spmin: integer;
    DistanzArray: array [0..maxLen] of integer;    //!!!!!!!!!!
Begin
  spmin := 0;
 
  if (Fehlerlimit = 0) then begin
     // Anfangsbuchstaben vergleichen
     if  (lenMuster >= 1) and (lenWort >= 1)
     and (IstohneErwSuchzeichen(Muster[1])and (Muster[1] <> Wort[1]))
        then spmin := maxLen;// dann spmin = 50
  end;
 
  if  (Fehlerlimit = 1) then begin
     // die ersten zwei Buchstaben vergleichen
     if  (lenMuster > 2) and (lenWort >= 2)
     and (IstohneErwSuchzeichen(Muster[1])) and (IstohneErwSuchzeichen(Muster[2]))
     and (Muster[1] <> Wort[1]) and (Muster[1] <> Wort[2])
     and (Muster[2] <> Wort[1]) and (Muster[2] <> Wort[2])
        then spmin := maxlen; { dann  spmin = 50 }
  end;
 
  if (spmin <= Fehlerlimit) then begin
     // Sternchen (*) zählen
     j := 0;
     for i :=1 to lenMuster do begin
        if (Muster[i] = '*') then j := j+1;
     end;
 
     // Wortlängen prüfen
     i := lenMuster-j-lenWort;
     if (i * EIN1 > Fehlerlimit) or ((j = 0) and (i * DEL1 < -Fehlerlimit))
        then spmin := maxlen;
  end;
 
  if (spmin <= Fehlerlimit) then begin
     // Anfangswerte berechnen
     if (lenMuster = 0) then begin
        for i := 0 to lenWort do DistanzArray[i] := i * DEL1 // DistanzArray:= 123456789...}
     end else if (Muster[1] = '*') then begin
        for i := 0 to lenWort do DistanzArray[i] := 0 // DistanzArray:= 000000000...
     end
 
     else begin
        if (Muster[1] = '?') then Ersetzen := 0
        else Ersetzen := Min (ERS1, ERS1, DEL1+EIN1);
        DistanzArray[0] := EIN1;
        DistanzArray[1] := EIN1;
        DistanzArray[2] := EIN1;
 
        for i := 1 to lenWort do begin
           if (Wort[i] = Muster[1]) then Ersetzen := 0;
           DistanzArray[i] := (i-1) * DEL1 + Ersetzen;
        end;
        spmin := MIN (DistanzArray[0],DistanzArray[1],DistanzArray[2]);
     end;
  end;
 
  // Distanzmatrix berechnen
  j := 1;
  while (j < lenMuster) and (spmin <= Fehlerlimit) do begin
     j := j+1;
     Ch := Muster[j];
     if (Ch = '*') or (Ch = '?')then Ersetzen  := 0 else Ersetzen  := ERS1;
     if (Ch = '*')              then Einfuegen := 0 else Einfuegen := EIN1;
     if (Ch = '*')              then Loeschen  := 0 else Loeschen  := DEL1;
     DistanzArray_2 := DistanzArray[0];
     DistanzArray[0] := DistanzArray[0] + Einfuegen;
     spmin := DistanzArray[0];
 
     for i := 1 to lenWort do begin
        // DistanzArray[i] := Minimum dreier Zahlen
        DistanzArray_1 := DistanzArray_2;
        DistanzArray_2 := DistanzArray[i];
        if (Wort[i] = Ch) then pp := 0 else pp := Ersetzen;
        DistanzArray[i] :=
           MIN (DistanzArray_1+pp, DistanzArray_2+Einfuegen, DistanzArray[i-1]+Loeschen);
        if (DistanzArray[i] < spmin) then spmin := DistanzArray[i];
     end
  end;
 
  if  ((spmin <= Fehlerlimit) and (DistanzArray[lenWort] <= Fehlerlimit))
     then J := DistanzArray[lenWort] else J := maxlen;
  if FBeachte_1Buchstaben then
    if FImString[1] = FFindeMuster[1] then J := J-1;
  FErgebnis := J; WLD := J;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
procedure TLevensteinSuchfunktion.SetWeitereZeichenInErweiterteSuche(Value:string);
begin
  FWeitereZeichenInErweiterteSuche := Value;
  if FWeitereZeichenInErweiterteSuche <> '' then begin
    Value := TrimRight(Value);
    Value := TrimLeft(Value);
    if Pos('*', Value) <> 0 then Delete(Value, Pos('*', Value), 1);
    if Pos(' ', Value) <> 0 then Delete(Value, Pos(' ', Value), 1);
    if Value <> '' then begin
      hasWeitereZeichen := true;
      FWeitereZeichenInErweiterteSuche := Value;
    end else hasWeitereZeichen := false;
  end else hasWeitereZeichen := false;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
// Wandelt 'Wort' in Großschreibung um
// Expandiert Umlaute
// (n = Zeichen von 'Ziel')
// Zurückgegeben wird Stringlänge von 'Ziel'
procedure TLevensteinSuchfunktion.SetAsymetrieausgleich(Value:boolean);
var tmpStr: string;
    i: integer;
begin
  FAsymetrieausgleich := value;
  if (FAsymetrieausgleich
    and (lenWort < lenMuster-1)
    and not ((FFindeMuster[1] = '*') or (FFindeMuster[2] = '*'))) then begin
      tmpStr := Wort;
      Muster   := Wort;
      Muster := tmpStr;
      i := lenWort; lenWort := lenMuster; lenMuster := i;
    end;
end;
 {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
procedure TLevensteinSuchfunktion.SetFindeMuster(Value:string);
begin
  FFindeMuster := Value;
  if FFindeMuster <> '' then begin
    Value := TrimRight(Value);
    Muster := Value;
    lenMuster := Length(Muster);
    if (lenMuster > MaxVergleich) then lenMuster := MaxVergleich;
    hasFindeMuster := true;
  end else begin
    hasFindeMuster := false;
    lenWort := 0; // kann vielleicht noch weg!
  end;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
procedure TLevensteinSuchfunktion.SetImString(Value:string);
begin
  FImString := Value;
  If FImString <> '' then begin
    Wort := Value;
    lenWort := Length(Wort);
    if (lenWort > MaxVergleich) then lenWort := MaxVergleich;
    hasImString := true;
  end else begin
    hasImString := false;
    lenWort := 0;
  end;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
{bei Abkürzungen erw. Suchmaske,}
{bei Umlaute jedes Zeichen}
procedure TLevensteinSuchfunktion.SetRechtschreibungstolerant(Value:boolean);
  type TCharSet = set of Char;
  var i : Integer;
      Abkuerzungen: TCharSet;
      Umlaute, UmlauteErsatz :String;
      PosCh: integer;
begin
  FRechtschreibungstolerant := Value;
  if FRechtschreibungstolerant and hasFindeMuster and hasImString then begin
    Abkuerzungen := ['+','-','&','.'];
    if hasWeitereZeichen then
      for i := 1 to length(FWeitereZeichenInErweiterteSuche) do begin
        if not (FWeitereZeichenInErweiterteSuche[i] in Abkuerzungen) then
          Abkuerzungen := Abkuerzungen+[FWeitereZeichenInErweiterteSuche[i]];
    end;
    Umlaute :=       'ÄäÖöÜüß';
    UmlauteErsatz := 'AaOoUus';
    For i := 1 to lenMuster do begin
      if (Muster[i] in Abkuerzungen) then Muster[i] := '*';
      PosCh := Pos(Muster[i], Umlaute);
      if PosCh > 0 then begin
        Delete(Muster, i, 1);
        if PosCh = 7 then Insert('?'+'ss', Muster, i)
        else              Insert('?'+UmlauteErsatz[PosCh], Muster, i);
      end;
    end;
  end;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
{Erweiterte Suchemaske wie in Paradox}
procedure TLevensteinSuchfunktion.SetErweiterte_Suche(Value:boolean);
  var i,j,k : Integer; ch: char;
Begin
  FErweiterte_Suche := Value;
  If FErweiterte_Suche and hasFindeMuster and hasImString then begin
    For i := 1 to lenMuster do
      if (Muster[i] = ' ') then Muster[i] := '*';
    Muster := Muster + '*';
    lenMuster := lenMuster+1;
    while Pos('**', Muster) > 0 do Delete(Muster, Pos('**', Muster), 1);
  end;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
procedure TLevensteinSuchfunktion.SetBeachte_GrossKleinschreibung(Value:boolean);
begin
  FBeachte_GrossKleinschreibung := Value;
  if Beachte_GrossKleinschreibung = false  and hasFindeMuster and hasImString then begin
    Muster := Uppercase(Muster);
    Wort := Uppercase(Wort);
  end;  
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
Function TLevensteinSuchfunktion.Execute : boolean;
begin
  SetImString(FImString);
  SetFindeMuster(FFindeMuster);
  SetAsymetrieausgleich(FAsymetrieausgleich);
  SetBeachte_GrossKleinschreibung(FBeachte_GrossKleinschreibung);
  SetWeitereZeichenInErweiterteSuche(FWeitereZeichenInErweiterteSuche);
  SetRechtschreibungstolerant(FRechtschreibungstolerant);
  SetErweiterte_Suche(FErweiterte_Suche);
  Fehlerlimit := FFehlerlimit;
  if WLD  <= Fehlerlimit then Execute := true else Execute := false;
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
 
Function TLevensteinSuchfunktion.ExecuteDirect
        (Wort, Muster, weitereZ: string;GK, ErwS, RSchr, Asym: Boolean; Limit: Byte) : boolean;
begin
  SetImString(Wort);
  SetFindeMuster(Muster);
  SetAsymetrieausgleich(Asym);
  SetBeachte_GrossKleinschreibung(GK);
  SetWeitereZeichenInErweiterteSuche(weitereZ);
  SetErweiterte_Suche(ErwS);
  SetRechtschreibungstolerant(RSchr);
  Fehlerlimit := Limit;
  if WLD  <= Fehlerlimit then ExecuteDirect := true else ExecuteDirect := false;
end;
 
procedure Register;
begin
  RegisterComponents('Neue', [TLevensteinSuchfunktion]);
end;
 
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
end.