Quelle Matching.pas Sprache: Delphi

unit Matching;

interface

//-------------------------------------------------------
//
//-------------------------------------------------------
uses
  Dialogs, ExtCtrls, Grids, ValEdit, Menus, Options,
  ComCtrls, SysUtils, StrUtils, Classes, Math, Forms,
  Controls, //OleAuto,
  //-------------------------------------------------------
  //
  //-------------------------------------------------------
  Utilities, Language;

//-------------------------------------------------------
//
//-------------------------------------------------------
type
  PMatch = ^TMatch;

  TMatch = record
    valid: boolean;
    manuell: boolean;
    leftline: integer;
    rightline: integer;
    leftcol: integer;
    rightcol: integer;
    MatchString: String;
  end;

  //-------------------------------------------------------
  //
  //-------------------------------------------------------
function ListRec(LV: TListView; ix: integer; left: boolean): String;
function importfile(lr: integer; Name: String; VL: TListView;
  first: boolean): boolean;
procedure setmatchbounds(RSI, FSI, FDI, ECI: String);
function hasmatch(Left, Right: TListItem): PMatch;
function exportfile(Name: String; VL1, VL2: TListView; Regex1, Regex2: String;
  ron: boolean): integer;
procedure getmatchingColumns();
procedure setPivotOnly();
function isinMatches(l, r: integer): integer;
function finditem(LV: tlistview; inx: integer): integer;

//-----------------------------------------------------------
//printable form of e.g. tab is #09
//-----------------------------------------------------------
var
  FSB, //field separator binary
  RSB, //record separator binary
  FDB, //field delimiter binary
  ECB:
  //escape character binary
    String;
  lfs, lrs, lfd, lec: //length of ...
    integer;
  numberrecords: array [1 .. 2] of integer;
  maxfieldsperrecord: array [1 .. 2] of integer;
  leftwidths, rightwidths: array of integer;
  Pivot: array [1 .. 2] of array of integer;
  Matches: array of PMatch;
  Mostleft, Mostright, RecPos: integer;
  ActMatch: PMatch;
  Exportcancel: Cardinal;

  //-------------------------------------------------------
  //
  //-------------------------------------------------------
implementation

var
  MF: array [1 .. 2] of TextFile;
  Filenames: array [1 .. 2] of String;
  inx: 1 .. 2;

  //-------------------------------------------------------
  //
  //-------------------------------------------------------
function endfile(): boolean;
begin
  result := EOF(MF[inx])
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
function stripof(S: String): String;
var
  ll: integer;
  R: String;
begin
  ll := length(S);
  R := S;
  if S > '' then begin
    if MidStr(S, 1, lfd) = FDB then begin
      if MidStr(S, ll - lfs + 1, lfs) = FSB then
        R := MidStr(S, 1 + lfd, length(S) - lfs - 2 * lfd)
      else
        R := MidStr(S, 1 + lfd, length(S) - 2 * lfd)
    end
    else if MidStr(S, ll - lfs + 1, lfs) = FSB then
      R := MidStr(S, 1, length(S) - lfs)
  end;
  result := R
end;

//------------------------------------------------------------------
//
//------------------------------------------------------------------
function finditem(LV: tlistview; inx: integer): integer;
var
  i, res, zwi: integer;
begin
  res := inx;
  i := 0;
  while (i < LV.Items.Count) do begin
    zwi := StrToInt(LV.Items[i].Caption);
    if zwi = inx then begin
      res := i;
      i := lv.Items.Count
    end;
    Inc(i)
  end;
  result := res
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
procedure setmatchbounds(RSI, FSI, FDI, ECI: String);
begin
  FSB := Hex2String(FSI);
  RSB := Hex2String(RSI);
  FDB := Hex2String(FDI);
  ECB := Hex2String(ECI);
  lfs := length(FSB);
  lrs := length(RSB);
  lfd := length(FDB);
  lec := length(ECB);
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
function getfield(Rec: String): String;
var
  k, i, ll: integer;
  isinfield: boolean;
  ch: char;
  Field: String;
  //--------------------------------------------
  procedure next();
  begin
    i := i + 1;
    if i <= ll then begin
      ch := Rec[i];
      Field := Field + Ch
    end
    else
      ch := chr(0);
  end;
//--------------------------------------------
  procedure skip();
  begin
    while (i < ll) and (Rec[i] = ' ') do
      Inc(i);
  end;

begin
  ll := length(Rec);
  Field := '';
  isinfield := false;
  i := RecPos;
  while (i < ll) and (Rec[i + 1] = ' ') do
    i := i + 1;
  next();
  if (FSB > '') and (ch = FSB[1]) then begin
    for k := 2 to lfs - 1 do
      next();
    skip();
    ch := chr(0);
  end;
  while (ch <> chr(0)) and (i <= ll) do begin
    if (ECB > '') and (ch = ECB[1]) then begin
      for k := 2 to lec - 1 do
        next();
    end
    else if isinfield then begin
      if (ch = FDB[1]) then begin
        isinfield := false;
        next();
        if ch <> FDB[1] then
          ch := chr(0);
      end
    end
    else if (FDB > '') and (ch = FDB[1]) then begin
      if lfd + i <= ll then begin
        isinfield := true;
        for k := i + 1 to i + lfd - 1 do
          isinfield := isinfield and (FDB[k - i + 1] = Rec[k]);
      end;
    end;
    if ch <> chr(0) then begin
      next();
      if not isinfield and (FSB > '') and (ch = FSB[1]) then begin
        for k := 2 to lfs - 1 do
          next();
        skip();
        ch := chr(0);
      end
    end
  end;
  Recpos := i;
  result := Field;
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
function getrecord(RS: String): String;
var
  k: integer;
  itis: boolean;
  ch: char;
  Rec: String;
  //--------------------------------------------
  procedure next();
  begin
    if endfile() then
      ch := chr(0)
    else
      read(MF[inx], ch);
  end;

begin
  Rec := '';
  itis := false;
  while not itis and not endfile() do begin
    next();
    if (RSB > '') and (ch = RSB[1]) then begin
      itis := true;
      for k := 2 to length(RSB) do begin
        if not endfile() then
          next()
        else
          ch := chr(0);
        itis := itis and (RSB[k] = Ch);
      end;
    end
    else
      Rec := Rec + ch;
  end;
  result := Rec
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
{$I similarity.inc}

//-------------------------------------------------------
//
//-------------------------------------------------------
function ListRec(LV: TListView; ix: integer; left: boolean): String;
var
  i, ll, Nums: integer;
  F, Sep: String;
begin
  Nums := strtoint(LV.Items[ix].Caption);
  F := LV.Items[ix].Caption + ': ';
  for i := 0 to LV.Items[ix].SubItems.Count - 1 do begin
    F := F + Sep + LV.Items[ix].SubItems[i];
    Sep := ';'
  end;
  ll := length(Matches);
  i := 0;
  while (i < ll) do begin
    if Matches[i].valid then begin
      if left and (nums = matches[i].leftline) then begin
        F := F + ' * ' + trans(54, 'Paar ') + '<' +
          inttostr(matches[i].leftline) + ',' + inttostr(matches[i].rightline) +
          '> ' + trans(64, 'mit') + ' ''' + matches[i].MatchString + ' ''';
        i := ll
      end
      else if not left and (nums = matches[i].rightline) then begin
        F := F + ' * ' + trans(54, 'Paar ') + '<' +
          inttostr(matches[i].leftline) + ',' + inttostr(matches[i].rightline) +
          '> ' + trans(64, 'mit') + ' ''' + matches[i].MatchString + ' ''';
        i := ll
      end;
    end;
    Inc(i)
  end;
  result := F
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
procedure setPivotOnly();
var
  le, ri, i: integer;
begin
  for i := 0 to length(Matches) - 1 do begin
    le := Matches[i].leftcol;
    ri := Matches[i].rightcol;
    if (le <> Mostleft) or (ri <> Mostright) then
      Matches[i].valid := false;
  end;
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
procedure getmatchingColumns();
var
  i, m1, m2, ll, lc, rc, c1, c2: integer;
begin
  m1 := 0;
  m2 := 0;
  c1 := 0;
  c2 := 0;
  ll := Length(Matches);
  for i := 0 to ll - 1 do begin
    if Matches[i].valid then begin
      lc := Matches[i].leftcol;
      rc := Matches[i].rightcol;
      if Pivot[1][lc] > m1 then begin
        c1 := lc;
        m1 := Pivot[1][lc]
      end;
      if Pivot[2][rc] > m2 then begin
        c2 := rc;
        m2 := Pivot[2][lc]
      end;
    end;
  end;
  Mostleft := c1;
  Mostright := c2
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
function isinMatches(l, r: integer): integer;
var
  i, ll: integer;
  res: integer;
begin
  res := -1;
  i := 0;
  ll := length(Matches);
  while (res < 0) and (i < ll) do begin
    if l = Matches[i].leftline then begin
      res := i;
      ActMatch := Matches[i]
    end;
    if r = Matches[i].rightline then begin
      res := i;
      ActMatch := Matches[i]
    end;
    i := i + 1;
  end;
  result := res
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
function hasmatch(Left, Right: TListItem): PMatch;
var
  i, j, ll1, ll2, bound: integer;
  M1, M2: String;
  aMatch: PMatch;
begin
  aMatch := nil;
  ll1 := Left.SubItems.count;
  ll2 := Right.SubItems.count;
  bound := min(ll1, ll2);
  i := 1;
  while (aMatch = nil) and (i < bound) do begin
    M1 := Left.subitems[i];
    j := 1;
    while (aMatch = nil) and (j < bound) do begin
      M2 := Right.subitems[j];
      if issimilar(M1, M2) then begin
        aMatch := new(PMatch);
        aMatch.valid := true;
        aMatch.manuell := false;
        aMatch.MatchString := M1;
        aMatch.leftline := StrToInt(Left.Caption);
        aMatch.rightline := StrToInt(Right.Caption);
        aMatch.leftcol := i;
        aMatch.rightcol := j;
        Inc(Pivot[1][i]);
        Inc(Pivot[2][j]);
      end;
      Inc(j);
    end;
    Inc(i)
  end;
  result := aMatch
end;

//-------------------------------------------------------
//NYI
//-------------------------------------------------------
procedure importexcelfile(Name: String; VL: TListView; first: boolean);
//var
//Excel, XLSheet: Variant;
//Rows, Cols: integer;
begin
  //Excel := CreateOleObject('Excel.Application');
  //Excel.visible := false;
  //Excel.WorkBooks.Open(Name);
  //XLSheet := Excel.Worksheets[1];
  //Cols := XLSheet.UsedRange.Columsn.count;
  //Rows := XLSheet.UsedRange.Columsn.count;
end;

//-------------------------------------------------------
//NYI
//-------------------------------------------------------
procedure importofficefile(Name: String; VL: TListView; first: boolean);
//var
//Office, OOSheet: Variant;
//Rows, Cols: integer;
begin
  //Office := CreateOleObject('com.sun.star.ServiceManager');
  //Office.visible := false;
  //Office.WorkBooks.Open(Name);
  //OOSheet := Office.Worksheets[1];
  //Cols := OOSheet.UsedRange.Columsn.count;
  //Rows := OOSheet.UsedRange.Columsn.count;
end;

//-------------------------------------------------------
//NYI
//-------------------------------------------------------
procedure importxmlfile(Name: String; VL: TListView; first: boolean);
//var
//Office, OOSheet: Variant;
//Rows, Cols: integer;
begin
  //Office := CreateOleObject('com.sun.star.ServiceManager');
  //Office.visible := false;
  //Office.WorkBooks.Open(Name);
  //OOSheet := Office.Worksheets[1];
  //Cols := OOSheet.UsedRange.Columsn.count;
  //Rows := OOSheet.UsedRange.Columsn.count;
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
function importcsvfile(Name: String; VL: TListView; first: boolean): boolean;
var
  i, j: integer;
  open: boolean;
  Rec, Field, This: String;
  LI: TListItem;
begin
  if FileExists(Name) then begin
    AssignFile(MF[inx], Name);
    try
      Reset(MF[inx]);
      open := true
    except
      open := false;
    end;
    if open then begin
      VL.Clear;
      VL.Items.Clear;
      VL.Columns.Add();
      VL.Columns[0].Caption := '#';
      //set headers
      //--------------------------------------------
      //now get records
      //--------------------------------------------
      maxfieldsperrecord[inx] := 0;
      i := -1;
      while not endfile() do begin
        Rec := getrecord(RSB);
        Inc(i);
        LI := nil;
        VL.Hint := '';
        RecPos := 0;
        j := 0;
        field := getfield(Rec);
        while Field <> '' do begin
          Inc(j);
          if j > maxfieldsperrecord[inx] then begin
            VL.Columns.Add();
            Inc(maxfieldsperrecord[inx]);
          end;
          This := stripof(Field);
          if (i = 0) then begin
            if first then
              VL.Columns[j].Caption := This
            else
              VL.Columns[j].Caption := inttostr(j);
          end;
          if not first or (i <> 0) then begin
            if LI = nil then begin
              LI := VL.Items.Add();
              LI.Caption := inttostr(i);
            end;
            LI.SubItems.Add(This);
          end;
          VL.Hint := VL.Hint + This;
          field := getfield(Rec);
        end;
      end;
    end;
    closefile(MF[inx]);
    VL.Columns[0].Width := vl.Width div (maxfieldsperrecord[inx] + 1);
    for j := 1 to maxfieldsperrecord[inx] - 1 do
      VL.Columns[j].Width := vl.Width div (maxfieldsperrecord[inx] + 1);
    setlength(Pivot[inx], maxfieldsperrecord[inx] + 1);
    for i := 1 to length(Pivot[inx]) do
      Pivot[inx][i] := 0;
    result := true;
  end
  else begin
    result := ask(47, 'Kann die Datei nicht lesen', ' ', [mbOK, mbCancel])
      = mrCancel;
  end;
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
function importfile(lr: integer; Name: String; VL: TListView;
  first: boolean): boolean;
var
  ext: String;
begin
  screen.Cursor := crHourGlass;
  result := true;
  inx := lr;
  Filenames[inx] := Name;
  ext := ExtractFileExt(Name);
  if Ext = '.xls' then
    errorn(37, 'Filter für Excel noch nicht implementiert')
  else if Ext = '.ods' then
    errorn(37, 'Filter für OpenOffice noch nicht implementiert')
  else
    result := importcsvfile(Name, VL, first);
  Screen.Cursor := crDefault;
end;

//-------------------------------------------------------
//
//-------------------------------------------------------
function exportfile(Name: String; VL1, VL2: TListView; Regex1, Regex2: String;
  ron: boolean): integer;
var
  cc1, cc2, su1, su2, i, j, numrec: integer;
  Outx: Textfile;
  open: boolean;
  Rec1, Rec2, Rec, sep, sepf, test: String;
  lcols, rcols: array of integer;
  //------------------------------------------------
  procedure collist(Rex: String; left: boolean);
  var
    i, ll, num, al: integer;
  begin
    al := 0;
    ll := length(Rex);
    i := 1;
    num := 0;
    while i <= ll do begin
      if (i = ll) or (Rex[i] = ',') then begin
        if i = ll then
          num := num * 10 + ord(Rex[i]) - ord('0');
        if left then begin
          SetLength(lcols, al + 1);
          lcols[al] := num;
          Inc(al);
        end
        else begin
          SetLength(rcols, al + 1);
          rcols[al] := num;
          Inc(al);
        end;
        num := 0;
      end
      else
        num := num * 10 + ord(Rex[i]) - ord('0');
      Inc(i);
    end;
  end;

begin
  collist(Regex1, true);
  collist(Regex2, false);
  //
  numrec := 0;
  exportcancel := 0;
  AssignFile(Outx, Name);
  try
    Rewrite(Outx);
    open := true
  except
    open := false;
  end;
  if open then begin
    cc1 := VL1.Items.Count;
    cc2 := VL2.Items.Count;
    for i := 0 to max(cc1, cc2) - 1 do begin
      if not ron then begin
        Rec1 := '';
        if i < cc1 then begin
          su1 := VL1.Items[i].SubItems.Count;
          Sep := '';
          for j := 0 to su1 - 1 do begin
            Rec1 := Rec1 + Sep + VL1.Items[i].SubItems[j];
            Sep := FSB
          end;
        end;
        Rec2 := '';
        if i < cc2 then begin
          su2 := VL2.Items[i].SubItems.Count;
          Sep := '';
          for j := 0 to su2 - 1 do begin
            Rec2 := Rec2 + Sep + VL2.Items[i].SubItems[j];
            Sep := FSB
          end;
        end;
        if Rec1 > '' then
          Rec := Rec1 + FSB + Rec2
        else
          Rec := Rec2;
        Write(Outx, Rec + RSB);
        Inc(numrec)
      end
      else if (i < min(cc1, cc2)) then begin
        Rec1 := '';
        Sep := '';
        Sepf := FDB;
        test := ListRec(vl1, i, true);
        for j := 0 to length(lcols) - 1 do
          if lcols[j] < vl1.Items[i].SubItems.Count then begin
            Rec1 := Rec1 + Sep + Sepf + vl1.Items[i].SubItems
              [lcols[j] - 1] + sepf;
            Sep := FSB;
          end;
        Rec2 := '';
        Sep := '';
        for j := 0 to length(rcols) - 1 do
          if rcols[j] < vl2.Items[i].SubItems.Count then begin
            Rec2 := Rec2 + Sep + sepf + vl2.Items[i].SubItems
              [rcols[j] - 1] + sepf;
            Sep := FSB;
          end;
        Rec := Rec1 + FSB + Rec2;
        Write(Outx, Rec + RSB);
        Inc(numrec)
      end;
    end;
    CloseFile(Outx);
  end
  else begin
    exportcancel := ask(46, 'Kann die Datei nicht auf die Festplatte schreiben',
      ' ', [mbOK, mbCancel]);
  end;
  result := numrec
end;

end.

quality89%

¤ Dauer der Verarbeitung: 0.16 Sekunden (vorverarbeitet) ¤

Wurzel

Die Arbeitsteilung ist notwendig ...

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.