(******************************************************************************
Text-Datei sortieren (ganz oder zum Teil im Arbeitsspeicher)
******************************************************************************)
unit UFileQuickSort;
interface
uses SysUtils, Classes, Dialogs;
resourcestring
txt_SourceFileError = '
Quell-Datei kann nicht geöffnet werden!';
txt_TargetFileError = '
Ziel-Datei kann nicht geöffnet werden!';
txt_StatusIndex = '
Index wird aufgebaut...';
txt_StatusSort = '
Sortiere Datei (%d%%)';
txt_StatusWrite = '
Schreibe Ziel-Datei...';
txt_StatusDone = '
Fertig.';
const
CancelFileQuickSort : Boolean = False;
type
TFileQuickSortCallBack =
procedure(Status :
String; PercentDone : Integer);
procedure FileQuickSort(
const SourceFileName, TargetFileName: AnsiString;
PrefetchSize : Word;
CallBackProcedure : TFileQuickSortCallBack =
NIL);
implementation
procedure FileQuickSort(
const SourceFileName, TargetFileName: AnsiString;
PrefetchSize : Word;
CallBackProcedure : TFileQuickSortCallBack =
NIL);
const
FileIndexBlock = 100000;
type
TGetLineTyp = (glt_File, glt_FileUpper, glt_Prefetch);
TLineIndex =
record
offset,
size : Integer;
prefetch : AnsiString;
end;
TFileIndex =
array of TLineIndex;
var
Promille, LastPromille : Integer;
FileIndex : TFileIndex;
SourceFStream : TFileStream;
{<--- Index aufbauen --->}
procedure LoadFileIndex;
var
i, Offset, Reserved : Integer;
InFile : TextFile;
TmpStr : AnsiString;
begin
i := 0;
Offset := 0;
Reserved := FileIndexBlock;
SetLength(FileIndex, Reserved);
if PrefetchSize > 1024
then PrefetchSize := 1024;
AssignFile(InFile, SourceFileName);
{$I-}
Reset(InFile);
{$I+}
if IOResult = 0
then begin
while not eof(InFile)
do begin
ReadLN(InFile, TmpStr);
FileIndex[i].offset := Offset;
FileIndex[i].size := Length(TmpStr);
FileIndex[i].prefetch := AnsiUpperCase(Copy(TmpStr,1,PrefetchSize));
Offset := Offset + FileIndex[i].size + 2;
inc(i);
// Mehr Index-Speicher reservieren
if i >= Reserved
then begin
Reserved := Reserved + FileIndexBlock;
SetLength(FileIndex, Reserved);
end;
end;
CloseFile(InFile);
end else ShowMessage(txt_SourceFileError);
SetLength(FileIndex, i);
end;
{<--- Holt eine Textzeile via Index --->}
function GetLine(Idx : Integer; LineTyp : TGetLineTyp): AnsiString;
function LineFromFile: AnsiString;
var
CharStr : PAnsiChar;
index : TLineIndex;
begin
index := FileIndex[Idx];
CharStr := StrAlloc(
Index.size +1);
FillChar(CharStr^,
Index.size +1, #0);
SourceFStream.Seek(
Index.offset, soFromBeginning);
SourceFStream.
Read(CharStr^,
Index.size);
Result := CharStr;
StrDispose(CharStr);
end;
begin
case LineTyp
of
glt_File : Result := LineFromFile;
glt_FileUpper : Result := AnsiUpperCase(LineFromFile);
glt_Prefetch : Result := FileIndex[Idx].prefetch;
end;
end;
{<--- Index Sortieren --->}
procedure QuickSort(LoIndex, HiIndex: Integer; LineTyp : TGetLineTyp);
var
LoIdx, HiIdx: Integer;
Pivot:
String;
Swap : TLineIndex;
begin
if CancelFileQuickSort
then Exit;
// Lokalen Indexbereich bilden
LoIdx := LoIndex;
HiIdx := HiIndex;
// Mittelwert muss noch optimiert werden
Pivot := GetLine((LoIndex + HiIndex)
div 2, LineTyp);
repeat
while GetLine(LoIdx, LineTyp) < Pivot
do Inc(LoIdx);
while Pivot < GetLine(HiIdx, LineTyp)
do Dec(HiIdx);
if LoIdx <= HiIdx
then begin
if LoIdx < HiIdx
then begin
Swap := FileIndex[LoIdx];
FileIndex[LoIdx] := FileIndex[HiIdx];
FileIndex[HiIdx] := Swap;
end;
Inc(LoIdx);
Dec(HiIdx);
end;
until LoIdx > HiIdx;
// CallBack nur alle 0,1% aufrufen
if Assigned(CallBackProcedure)
then begin
Promille := (LoIndex * 1000)
div Length(FileIndex);
if Promille > LastPromille
then begin
LastPromille := Promille;
CallBackProcedure(Format(txt_StatusSort,[Promille
div 10]), Promille
div 10);
end;
end;
if LoIndex < HiIdx
then QuickSort(LoIndex, HiIdx, LineTyp);
if LoIdx < HiIndex
then QuickSort(LoIdx, HiIndex, LineTyp);
end;
{<--- Zieldatei schreiben --->}
procedure WriteTargetFile;
var
OutFile : TextFile;
i,i2, LoIdx, HiIdx : Integer;
begin
AssignFile(OutFile, TargetFileName);
{$I-}
Rewrite(OutFile);
{$I+}
if IOResult = 0
then begin
// An Index ein zum Letzten ungleichen Prefetch anhängen
i := Length(FileIndex);
SetLength(FileIndex, i+1);
FileIndex[i].prefetch := FileIndex[i-1].prefetch + '
X';
i := 0;
repeat
// Wenn Index[n] <> Index[n+1] dann schreiben
if (PrefetchSize = 0)
or (FileIndex[i].prefetch <> FileIndex[i+1].prefetch)
then begin
WriteLN(OutFile, GetLine(i, glt_File));
inc(i);
// Ansonsten erstes gleiches merken und erstes ungleiches suchen
end else begin
LoIdx := i;
HiIdx := i+1;
while FileIndex[LoIdx].prefetch = FileIndex[HiIdx].prefetch
do Inc(HiIdx);
// Nachsortieren, diesmal mit ganzer Zeile
QuickSort(LoIdx,HiIdx, glt_FileUpper);
// Schreiben
for i2 := LoIdx
to HiIdx
do
WriteLN(OutFile, GetLine(i2, glt_File));
i := HiIdx +1;
end;
if CancelFileQuickSort
then i := Length(FileIndex);
until i > Length(FileIndex)-2;
CloseFile(OutFile);
end else ShowMessage(txt_SourceFileError);
end;
{<--- Haupt Routine --->}
begin
CancelFileQuickSort := False;
// Index aufbauen
if Assigned(CallBackProcedure)
then CallBackProcedure(txt_StatusIndex, 0);
LoadFileIndex;
try
// Quelldatei exclusiv öffnen, wir wollen ja keine verfälschten Ergebnisse
SourceFStream := TFileStream.Create(SourceFileName,fmOpenRead
or fmShareExclusive);
try
If (Length(FileIndex) > 0)
and not CancelFileQuickSort
then begin
// Index (Vor-)Sortieren
LastPromille := 0;
// Wenn PrefetchSize > 0 muss bei schreiben evtl. nachsortiert werden!
if PrefetchSize > 0
then QuickSort(0, Length(FileIndex)-1, glt_Prefetch)
else QuickSort(0, Length(FileIndex)-1, glt_FileUpper);
// Zieldatei schreiben
if Assigned(CallBackProcedure)
then CallBackProcedure(txt_StatusWrite, 99);
if not CancelFileQuickSort
then WriteTargetFile;
end;
finally
SourceFStream.Free;
end;
// Quelldatei Fehler
except
on EFOpenError
do ShowMessage(txt_SourceFileError);
end;
// Wer hätte das im Vorfeld erwartet? Fertig!
if Assigned(CallBackProcedure)
then CallBackProcedure(txt_StatusDone, 100);
end;
end.