const
  CancelFileQuickSort : Boolean = False;

type
  TFileQuickSortCallBack = procedure(Status : String; PercentDone : Integer);

procedure FileQuickSort(const SourceFileName, TargetFileName: AnsiString;
                        PrefetchSize : Word;
                        CallBackProcedure : TFileQuickSortCallBack = NIL);

(******************************************************************************
  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.

Function CompareTextlines (aIdx1, aIdx2 : TLineIndex) : Shortint; // -1: aIdx1<aIdx2, 0: beide gleich
Begin
  Result := CompareString (aIdx1.prefetch, aIdx2.prefetch);
  If Result = 0 Then // prefetch-Strings sind identisch, also nachladen, um sicher zu sein
     Result := CompareString (ReadLine (aIdx1), ReadLine (aIdx2));
End;