{+--------------------------------------------------------------------------+
 | Unit:   mwTextSort
 | Created:     15.07.97
 | Author:      Martin Waldenburg
 | Copyright    1997, all rights reserved.
 | Description: A text sorter for an unlimmited amount of text using
 |              a three-way merge for memory and a five-way merge  for files.
 | Version:     1.0
 | Status       FreeWare
 | It's provided as is, without a warranty of any kind.
 | You use it at your own risc.
 | E-Mail me at Martin.Waldenburg@t-online.de
 +--------------------------------------------------------------------------+}

unit mwTextSort;

{$R-}



interface

uses SysUtils, Windows, Classes;

type
  TMergeCompare = function (Item1, Item2: Pointer): Integer;
  PMergeArray = ^TMergeArray;
  TMergeArray = array[0..0] of Pointer;
  PMergeData = ^TMergeData;
  TMergeData = record
          Data : String;
         end;


{ TSub3Array defines the boundaries of a SubArray and determines if
  the SubArray is full or not.
  The MergeSort Algorithm is easier readable with this class.}
type
  TSub3Array = class(TObject)
  private
    FMax: LongInt;
  protected
  public
    FLeft: LongInt;  { - Initialized to 0. }
    FRight: LongInt;  { - Initialized to 0. }
    Full: Boolean;
    constructor Create(MaxValue: LongInt);
    destructor Destroy; override;
    procedure Init(LeftEnd, RightEnd: LongInt);
    procedure Next;
  end;  { TSub3Array }

type

{ TM3Array class }
  TM3Array = class(TObject)
  private
    FLeftArray, FMidArray, FRightArray: TSub3Array;
    FM3Array, TempArray, SwapArray: PMergeArray;
    FCount: Integer;
    fCapacity:Integer;
    procedure SetCapacity(NewCapacity:Integer);
    procedure Expand;
  protected
    function Get(Index: Integer): Pointer;
    procedure Put(Index: Integer; Item: Pointer);
    procedure Merge(SorCompare: TMergeCompare);
  public
    destructor Destroy; override;
    function Add(Item: Pointer): Integer;
    procedure Clear;
    function Last: Pointer;
    procedure MergeSort(SorCompare: TMergeCompare);
    property Count: Integer read FCount write FCount;
    property Items[Index: Integer]: Pointer read Get write Put; default;
    property M3Array: PMergeArray read FM3Array;
    property Capacity:Integer read fCapacity write SetCapacity;
  published
  end;

type
  TTempFile = class(TObject)
  private
    fFileName: String;
    aTempFile: TextFile;
    TextLine: String;
    fFull:Boolean;
  protected
  public
    FLeft: PMergeData;
    constructor Create;
    destructor Destroy; override;
    procedure Next;
    procedure Init(FileName: String);
    property Full:Boolean read fFull;
  published
  end;

type
  TMergeFile = class(TObject)
  private
    FFileOne, FFileTwo, FFileThree, FFileFour, FFileFive: TTempFile;
    fOutFile: TextFile;
    fInList, fOutList, TempList: TStringList;
    fFileName:String;
  protected
  public
    constructor Create(InList: TStringList);
    destructor Destroy; override;
    procedure FileMerge(MergeCompare: TMergeCompare);
    procedure MergeSort(MergeCompare: TMergeCompare);
    property FileName:String read fFileName;
  published
  end;

type
  TTextSort = class(TObject)
  private
    FMaxLines: LongInt;
    FMaxMem: LongInt;
    fMerArray: TM3Array;
    MergeFile: TMergeFile;
    fFileName: String;
    fTempFileList: TStringList;
    fCompare: TMergeCompare;
  protected
  public
    MergeData: PMergeData;
    constructor Create(Compare: TMergeCompare);
    destructor Destroy; override;
    procedure Start;
    procedure Init(FileName: String);
    property MaxLines: LongInt read FMaxLines write FMaxLines default 60000;
    property MaxMem: LongInt read FMaxMem write FMaxMem default 4000000;
  published
  end;

implementation

constructor TSub3Array.Create(MaxValue: LongInt);
  begin
    FLeft := 0;
    FRight := 0;
    Full := False;
    FMax := MaxValue;
  end;  { Create }

procedure TSub3Array.Init(LeftEnd, RightEnd: LongInt);  { public }
  begin
    FLeft:= LeftEnd;
    FRight:= RightEnd;
    if FLeft > FMax then Full:= False else Full:= True;
  end;  { Init }

procedure TSub3Array.Next;
  begin
    inc(FLeft);
    if (FLeft > FRight) or (FLeft > FMax) then Full:= False;
  end;  { Next }

destructor TSub3Array.Destroy;
  begin
    inherited Destroy;
  end;  { Destroy }

{ TM3Array }
destructor TM3Array.Destroy;
begin
  Clear;
  inherited Destroy;
end;

function TM3Array.Add(Item: Pointer): Integer;
begin
  Result := FCount;
  if Result = FCapacity then Expand;
  FM3Array[Result] := Item;
  Inc(FCount);
end;

procedure TM3Array.Expand;
begin
  SetCapacity(FCapacity + 8192);
end;

procedure TM3Array.SetCapacity(NewCapacity:Integer);
begin
  FCapacity:= NewCapacity;
  ReallocMem(FM3Array, FCapacity * SizeOf(Pointer));
  ReallocMem(TempArray, FCapacity * SizeOf(Pointer));
end;

procedure TM3Array.Clear;
begin
  FCount:= 0;
  ReallocMem(TempArray, 0);
  ReallocMem(FM3Array, 0);
  FCapacity:= 0;
end;

function TM3Array.Get(Index: Integer): Pointer;
begin
  Result := FM3Array[Index];
end;

function TM3Array.Last: Pointer;
begin
  Result := Get(FCount - 1);
end;

procedure TM3Array.Put(Index: Integer; Item: Pointer);
begin
  FM3Array[Index] := Item;
end;

{This is a three way merge routine.
 Unfortunately the " Merge " routine needs additional memory
 An Algorithm to perform merging in linear time without extra space
 is described in:
 B. Huang and M. Langston, " Practical In-place Merging ",
 Communications of the ACM 31(1988), 348-352. }
procedure TM3Array.Merge(SorCompare: TMergeCompare);
var
  TempPos : integer;
begin
  TempPos := FLeftArray.FLeft;
   while ( FLeftArray.Full ) and ( FMidArray.Full ) and ( FRightArray.Full ) do  {Main Loop}
    begin
      if SorCompare(FM3Array[FLeftArray.FLeft], FM3Array[FMidArray.FLeft]) <= 0 then
        begin
          if SorCompare(FM3Array[FLeftArray.FLeft], FM3Array[FRightArray.FLeft]) <= 0 then
            begin
              TempArray[ TempPos ] := FM3Array[ FLeftArray.FLeft ];
              FLeftArray.Next;
            end
          else
            begin
              TempArray[ TempPos ] := FM3Array[ FRightArray.FLeft ];
              FRightArray.Next;
            end;
        end
      else
        begin
          if SorCompare(FM3Array[FMidArray.FLeft], FM3Array[FRightArray.FLeft]) <= 0 then
            begin
              TempArray[ TempPos ] := FM3Array[ FMidArray.FLeft ];
              FMidArray.Next;
            end
          else
            begin
              TempArray[ TempPos ] := FM3Array[ FRightArray.FLeft ];
              FRightArray.Next;
            end;
        end;
          inc(TempPos);
    end;

   while ( FLeftArray.Full ) and ( FMidArray.Full ) do
    begin
      if SorCompare(FM3Array[FLeftArray.FLeft], FM3Array[FMidArray.FLeft]) <= 0 then
        begin
          TempArray[ TempPos ] := FM3Array[ FLeftArray.FLeft ];
          FLeftArray.Next;
        end
      else
        begin
          TempArray[ TempPos ] := FM3Array[ FMidArray.FLeft ];
          FMidArray.Next;
        end;
          inc(TempPos);
    end;

  while ( FMidArray.Full ) and ( FRightArray.Full ) do
    begin
      if SorCompare(FM3Array[FMidArray.FLeft], FM3Array[FRightArray.FLeft]) <= 0 then
        begin
          TempArray[ TempPos ] := FM3Array[ FMidArray.FLeft ];
          FMidArray.Next;
        end
      else
        begin
          TempArray[ TempPos ] := FM3Array[ FRightArray.FLeft ];
          FRightArray.Next;
        end;
          inc(TempPos);
    end;

  while ( FLeftArray.Full ) and ( FRightArray.Full ) do
    begin
      if SorCompare(FM3Array[FLeftArray.FLeft], FM3Array[FRightArray.FLeft]) <= 0 then
        begin
          TempArray[ TempPos ] := FM3Array[ FLeftArray.FLeft ];
          FLeftArray.Next;
        end
      else
        begin
          TempArray[ TempPos ] := FM3Array[ FRightArray.FLeft ];
          FRightArray.Next;
        end;
          inc(TempPos);
    end;

 while FLeftArray.Full do    { Copy Rest of First Sub3Array }
    begin
      TempArray[ TempPos ] := FM3Array[ FLeftArray.FLeft ];
      inc(TempPos); FLeftArray.Next;
    end;

  while FMidArray.Full do    { Copy Rest of Second Sub3Array }
    begin
      TempArray[ TempPos ] := FM3Array[ FMidArray.FLeft ];
      inc(TempPos); FMidArray.Next;
    end;

 while FRightArray.Full do   { Copy Rest of Third Sub3Array }
    begin
      TempArray[ TempPos ] := FM3Array[ FRightArray.FLeft ];
      inc(TempPos); FRightArray.Next;
    end;
end;

{Non-recursive Mergesort.
 Very fast, if enough memory available.
 The number of comparisions used is nearly optimal, about 3/4 of QuickSort.
 If comparision plays a very more important role than exchangement,
 it outperforms QuickSort in any case.
 ( Large keys in pointer arrays, for example text with few short lines. )
 From all Algoritms with O(N lg N) it's the only stable, meaning it lefts
 equal keys in the order of input. This may be important in some cases. }
procedure TM3Array.MergeSort(SorCompare: TMergeCompare);
var
  a, b, c, N, todo: LongInt;
begin
  FLeftArray:= TSub3Array.Create(FCount -1);
  FMidArray:= TSub3Array.Create(FCount -1);
  FRightArray:= TSub3Array.Create(FCount -1);
  N:= 1;
  repeat
      todo:= 0;
      repeat
        a:= todo;
        b:= a +N;
        c:= b +N;
        todo:= C +N;
        FLeftArray.Init(a, b -1);
        FMidArray.Init(b, c -1);
        FRightArray.Init(c, todo -1);
        Merge(SorCompare);
      until todo >= Fcount;
      SwapArray:= FM3Array; {Alternating use of the arrays.}
      FM3Array:= TempArray;
      TempArray:= SwapArray;
      N:= N+ N +N;
    until N >= Fcount;
    FLeftArray.Free;
    FMidArray.Free;
    FRightArray.Free;
end;

constructor TTempFile.Create;
begin
  inherited Create;
   fFull:= False;
   New(fLeft);
end;  { Create }

procedure TTempFile.Init(FileName: String);
begin
  fFull:= False;
  fFileName:= FileName;
  if fFileName <> '' then
    begin
      AssignFile(aTempFile, fFileName);
      Reset(aTempFile);
      if not Eof(aTempFile) then
        begin
          Readln(aTempFile, TextLine);
          fLeft^.Data:= TextLine;
          fFull:= True;
        end
      else
        begin
          CloseFile(aTempFile);
          Erase(aTempFile);
          fFileName:= '';
        end;
    end;
end; { Init }

procedure TTempFile.Next;
begin
  if not Eof(aTempFile) then
    begin
      Readln(aTempFile, TextLine);
      fLeft^.Data:= TextLine;
      fFull:= True;
    end
  else
    begin
      fFull:= False;
      if fFileName <> '' then
      begin
          CloseFile(aTempFile);
          Erase(aTempFile);
          fFileName:= '';
      end;
    end
end;  { Next }

destructor TTempFile.Destroy;
begin
  Dispose(fLeft);
  if fFileName <> '' then
  begin
    CloseFile(aTempFile);
  end;
  inherited Destroy;
end;  { Destroy }


constructor TMergeFile.Create(InList: TStringList);
begin
  inherited Create;
  fInList:= InList;
end;  { Create }

destructor TMergeFile.Destroy;
begin
  inherited Destroy;
end;  { Destroy }

procedure TMergeFile.FileMerge(MergeCompare: TMergeCompare);
begin
    while ( FFileOne.Full ) and ( FFileTwo.Full ) and ( FFileThree.Full )
                           and ( FFileFour.Full ) and ( FFileFive.Full ) do  {Main Loop}
    begin
      if MergeCompare(FFileOne.FLeft, FFileTwo.FLeft) <= 0 then
        begin
          if MergeCompare(FFileThree.FLeft, FFileFour.FLeft) <= 0 then
            begin
              if MergeCompare(FFileOne.FLeft, FFileThree.FLeft) <= 0 then
                begin
                  if MergeCompare(FFileOne.FLeft, FFileFive.FLeft) <= 0 then
                    begin
                      writeln(fOutFile, FFileOne.fLeft^.Data);
                      FFileOne.Next;
                    end
                  else
                    begin
                      writeln(fOutFile, FFileFive.fLeft^.Data);
                      FFileFive.Next;
                    end;
                end
              else
                begin
                  if MergeCompare(FFileThree.FLeft, FFileFive.FLeft) <= 0 then
                    begin
                      writeln(fOutFile, FFileThree.fLeft^.Data);
                      FFileThree.Next;
                    end
                  else
                    begin
                      writeln(fOutFile, FFileFive.fLeft^.Data);
                      FFileFive.Next;
                    end;
                end
            end
          else
            begin
              if MergeCompare(FFileOne.FLeft, FFileFour.FLeft) <= 0 then
                begin
                  if MergeCompare(FFileOne.FLeft, FFileFive.FLeft) <= 0 then
                    begin
                      writeln(fOutFile, FFileOne.fLeft^.Data);
                      FFileOne.Next;
                    end
                  else
                    begin
                      writeln(fOutFile, FFileFive.fLeft^.Data);
                      FFileFive.Next;
                    end;
                end
              else
                begin
                  if MergeCompare(FFileFour.FLeft, FFileFive.FLeft) <= 0 then
                    begin
                      writeln(fOutFile, FFileFour.fLeft^.Data);
                      FFileFour.Next;
                    end
                  else
                    begin
                      writeln(fOutFile, FFileFive.fLeft^.Data);
                      FFileFive.Next;
                    end;