Eine aufbereitete Darstellung der Quelle

 
     
 
 
Anforderungen  |   Konzepte  |   Entwurf  |   Entwicklung  |   Qualitätssicherung  |   Lebenszyklus  |   Steuerung
 
 
 
 
Benutzer

products/Sources/formale Sprachen/C/LibreOffice/icon-themes/sifr_svg/cmd/   (LibreOffice Version 25.8.3.2©)  Datei vom 5.10.2025 mit Größe 721 B image not shown  

Bilddatei

Matching.pas.~510~


products/Sources/formale Sprachen/Delphi/Bille 0.71/__history/Matching.pas.~510~

unit Matching; interface //------------------------------------------------------- // //------------------------------------------------------- uses Dialogs, ExtCtrls, Grids, ValEdit, Menus, Options, ComCtrls, SysUtils, StrUtils, Classes, Math, Forms, Controls, //OleAuto, //------------------------------------------------------- // //------------------------------------------------------- Utilities, Language; //------------------------------------------------------- // //------------------------------------------------------- procedure setWidths(VL: TListView); 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): String; function exportfile(Name: String; VL1, VL2: TListView; ron: boolean): integer; procedure getmatchingColumns(); procedure setPivotOnly(); function isinMatches(l, r: integer): integer; //------------------------------------------------------- // //------------------------------------------------------- type TMatch = record valid: boolean; leftline: integer; rightline: integer; leftcol: integer; rightcol: integer; MatchString: String; end; //----------------------------------------------------------- //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; RecMatch1, RecMatch2: integer; Record1, Record2: String; ColMatch1, ColMatch2: integer; Pivot: array [1 .. 2] of array of integer; Matches: array of TMatch; Mostleft, Mostright, RecPos: integer; ActMatch: TMatch; 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; //------------------------------------------------------- // //------------------------------------------------------- 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; //------------------------------------------------------- // //------------------------------------------------------- procedure setWidths(VL: TListView); var j: integer; begin for j := 1 to VL.Columns.Count - 1 do VL.Columns[j].Width := VL.Width div (VL.Columns.Count + 1); 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, inx: integer; F, Sep: String;done:boolean; begin 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 then inx := matches[i].leftline else inx := matches[i].rightline; if (LV.Items[ix].Index = inx) then begin F := F + ' * ' + trans(54, 'Paar ') + '<' + inttostr(matches[i].leftline) + ',' + inttostr(matches[i].rightline) + ' ''' + 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): String; var i, j, ll1, ll2, bound: integer; res: boolean; M1, M2: String; begin res := false; ll1 := Left.SubItems.count; ll2 := Right.SubItems.count; bound := min(ll1, ll2); i := 1; while not res and (i < bound) do begin M1 := Left.subitems[i]; j := 1; while not res and (j < bound) do begin M2 := Right.subitems[j]; if issimilar(M1, M2) then begin RecMatch1 := left.Index; RecMatch2 := Right.Index; ColMatch1 := i; ColMatch2 := j; Inc(Pivot[1][ColMatch1]); Inc(Pivot[2][ColMatch2]); res := true; end; Inc(j); end; Inc(i) end; if res then result := M1 else result := '' 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; ron: boolean): integer; var cc1, cc2, su1, su2, i, j, numrec: integer; Outx: Textfile; open: boolean; Rec1, Rec2, Rec, sep: String; begin exportcancel := 0; AssignFile(Outx, Name); open := false; try Rewrite(Outx); open := true except //errorn(0, 'I have control again', '') end; if open then begin cc1 := VL1.Items.Count; cc2 := VL2.Items.Count; numrec := 0; 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 := vl1.Items[i].Caption; Rec2 := vl2.Items[i].Caption; 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.

                                                                                                                                                                                                                                                                                                                                                                                                     

Neuigkeiten

     Aktuelles
     Motto des Tages

letze Version des Elbe Quellennavigators

Jenseits des Üblichen ....

Besucher

Besucher
Statistik
#Sources=1126864
#Domains=2039723