{ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ}
{Û                                                       Û}
{Û      Virtual Pascal Examples. Version 2.1.            Û}
{Û      Example for sorting text files                   Û}
{Û      ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÛ}
{Û      Copyright (C) 1995-2000 vpascal.com              Û}
{Û                                                       Û}
{ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß}

{ This program implements a sort algorithm for sorting text files. }
{ It compiles and executes as a DOS program as well as an OS/2     }
{ program, and demonstrates the techniques used for making low-    }
{ level code usable by both operating systems.                     }

Program Sort;

{&PMTYPE VIO}
{&Delphi+,Use32+,T-,X+,H-}

Uses
  SysUtils, Dos, Timer;

const
  MaxFileSize = 20000000;

type
  ESort = class(Exception);
  tOptions  = ( ReverseOutput, GetLineLength );
  OptionSet = Set Of tOptions;

  { Types for manipulating very large arrays }
  ByteList  = Array[ 0..MaxInt div sizeof( Byte ) ] of Byte;
  WordList  = Array[ 0..MaxInt div sizeof( Word ) ] of Word;

var
  LongestWord : Longint;
  MeanLength  : Longint;

{ Initialize variables }

procedure Initialize( Var SourceFileName, DestFileName : String; Var Options: OptionSet );
begin
  SourceFileName  := '';
  DestFileName    := '';
  Options := [];
  LongestWord := 0;
end;

{ Close source and destination files }

procedure CloseFiles( Var InFile, OutFile : File );
begin
  Close( InFile );
  Close( OutFile );
end;

{ Parse command line parameters }

procedure ParseParameters( Var SourceFileName, DestFileName : String;
                         Var Options : OptionSet );
Var
  i : Word;
  s : String;

  procedure SyntaxError( ErrNo : Byte );
  begin
    Writeln;
    Case ErrNo of
      1 : Writeln('Error on command line; invalid parameter "',s,'"' );
      2 : Writeln('No source file name specified');
    end;
    Writeln;
    Writeln('Syntax:  SORT [-v] [-l] SourceFile [DestFile]');
    Writeln('         -v: Output in reverse order');
    Writeln('         -l: Display line length statistics');
    Raise ESort.Create('Invalid parameters specified');
  end;

  procedure ParseOption;
  begin
    Case Upcase( s[2] ) of
      'V' : Options := Options + [ReverseOutput];
      'L' : Options := Options + [GetLineLength];
    else
      SyntaxError( 1 );
    end;
  end;

begin
  For i := 1 to ParamCount do
    begin
      s := ParamStr( i );
      if s[1] = '-' then
        ParseOption
      else
        If SourceFileName = '' then
          SourceFileName := s
        else
          If DestFileName = '' then
            DestFileName := s
          else
            SyntaxError( 1 );
    end;
  If SourceFileName = '' then
    SyntaxError( 2 );
end;

{ Open input and output files }

procedure OpenFiles( Const SourceFileName, DestFileName : String;
                     Var InFile, OutFile : File );
begin
  Assign( InFile, SourceFileName );
  {$I-}
  Reset( InFile, 1 );
  {$I+}
  If IOResult <> 0 then
    raise ESort.Create('Cannot open input file '+SourceFileName);

  Assign( OutFile, DestFileName );
  {$I-}
  Rewrite( OutFile, 1 );
  {$I+}
  If IOResult <> 0 then
    raise ESort.Create('Cannot open output file '+DestFileName);

  Writeln('--- Input file is ',FileSize( InFile ),' bytes in size');
  Writeln;
end;

{ Main routine.  Sorts InFile, writes result to OutFile }

procedure SortFile( Var InFile, OutFile : File; Options : OptionSet );
Var
  InBufSize   : Word;
  InBuffer    : Pointer;
  SortSize    : Word;
  OutBufSize  : Word;
  OutBuffer   : PChar;
  Words       : Word;
  WordInxLen  : Word;
  WordIndex   : Pointer;
  SortIndex   : Pointer;

  { Reads source file into buffer }

  procedure ReadInFile;
  Var
    Check : Word;

  begin
    SortSize := FileSize( InFile );
    InBufSize := SortSize + 1;
    If InBufSize > MaxFileSize then
      raise ESort.Create('Source file too large');

    GetMem( InBuffer, InBufSize );
    BlockRead( InFile, InBuffer^, InBufSize-1, Check );
    If Check <> InBufSize-1 then
      raise ESort.Create('Error reading input file');

    If ByteList( InBuffer^ )[ SortSize ] <> 10 then
      begin
        Inc( SortSize );
        ByteList( InBuffer^ )[ SortSize ] := 10;
      end;

    OutBufSize := Round( InBufSize * 2 );
    GetMem( OutBuffer, OutBufSize );
    FillChar( OutBuffer^, OutBufSize, 0 );
    Words := 0;
  end;

  { Converts input buffer to sortable format }

  {$FRAME-} {$USES ebx,ecx,edx,esi,edi}
  Function ConvertBuffer( InBufSize : Word; InBuffer, OutBuffer : Pointer ) : Longint; assembler;
    asm
      mov    edx, InBufSize
      mov    edi, OutBuffer
      mov    esi, InBuffer
      add    edx, esi
      dec    edx

    @NextWord:
      xor    ecx, ecx
      mov    ebx, edi
      add    edi,4
      jmp    @first

    @NextCh:
      inc    ecx
      stosb

    @First:
      lodsb
      cmp    al,10
      jne    @NextCh
      mov    dword ptr [ebx], ecx
      cmp    ecx,[LongestWord]
      jle    @NotLongest
      mov    [LongestWord],ecx
    @NotLongest:
      inc    dword ptr [Words]

      cmp    esi, edx
      jb     @NextWord

      mov    eax, dword ptr [Words]
    end;

  { Builds an index of all strings in buffer }

  procedure GetStringIndex;
  Var
    Leng : Word;
    Inx  : Word;
    WInx : Word;

  begin
    WordInxLen := SizeOf( Word ) * Words;
    GetMem( WordIndex, WordInxLen );
    GetMem( SortIndex, WordInxLen );

    WInx := 0;
    Inx := 0;
    Repeat
      WordList( WordIndex^ )[ Winx ] := Inx;
      WordList( SortIndex^ )[ Winx ] := WInx;

      Leng := pLongint(OutBuffer+Inx)^ + 4;

      Inc( Inx, Leng );
      Inc( WInx );
    Until ( WInx >= Words );
  end;

  { Returns a pointer to and the length of the Nr'th string in }
  { the sorted list of strings }

  function GetStringPtr( Nr : Word; Var Len : Word ) : Pointer;
  Var
    Index : Word;
    p : PChar;

  begin
    Index := WordList( SortIndex^ )[ Nr ];
    p := @ByteList( OutBuffer^ )[ WordList( WordIndex^ )[ Index ] ];
    Len := pLongint(p)^;
    inc(p, 4);

    GetStringPtr := p;
  end;

  { Compares the string Str1, length StrLen1, with the StrNo'th }
  { string.  Returns 0 if equal, 1 if Str1 < Str2 and 2 otherwise }

  function CompareStr( Str1 : Pointer; Str1Len, StrNo : Word ) : Integer;
  assembler; {&uses ebx,esi,edi} {&Frame+}
  var
    Str2    : Pointer;
    Str2Len : Word;
    Len     : Word;
    LenComp : Word;

  asm
    push   StrNo
    lea    eax,Str2Len
    push   eax
    call   GetStringPtr
    mov    Str2, eax

    xor   eax, eax
    mov   [LenComp],eax
    mov   ecx, str1len
    mov   eax, str2len
    cmp   eax,ecx
    je    @lenok
    ja    @str2longest
    mov   ecx,eax
    mov   dword ptr [lencomp],1
    jmp   @lenok

  @str2longest:
    mov   dword ptr [lencomp],2

  @lenok:
    mov   len, ecx
    or    ecx,ecx
    je    @dupe

    { Compare string content }
    xor   ebx, ebx
    mov   esi, Str1
    mov   edi, Str2
    cmp   esi, edi
    je    @dupe
    jmp   @firstchar

  @nextchar:
    inc   ebx

  @firstchar:
    cmp   ebx, ecx
    jae   @dupe

    mov   al,[esi+ebx]
    cmp   al,[edi+ebx]

    je    @nextchar
    mov   eax, 2
    ja    @done
    mov   eax, 1
    jmp   @done

  @dupe:
    mov   eax, LenComp

  @done:
    // Always returns result in eax
  end;

  { Sort stringlist by manipulating tSortIndex array using Quicksort }
  { algorithm for sorting }

  procedure QuickSort( Lo, Hi : Word );
  var
    i,j,x   : Word;
    MidStr  : Pointer;
    MidLen  : Longint;
    SwapVal : Word;

  begin
    i := Lo;
    j := Hi;
    x := ( Lo + Hi ) div 2;
    MidStr := GetStringPtr( x, MidLen );
    repeat
      while ( CompareStr( MidStr, MidLen, i ) = 2 ) do
        inc( i );
      while ( CompareStr( MidStr, MidLen, j ) = 1 ) do
        dec( j );

      if ( i <= j ) then
        begin
          if i < j then
            begin
              SwapVal := WordList( SortIndex^ )[ i ];
              WordList( SortIndex^ )[ i ] := WordList( SortIndex^ )[ j ];
              WordList( SortIndex^ )[ j ] := SwapVal;
            end;
          inc( i );
          dec( j );
        end;
    until (i > j);

    if Lo < j then
      QuickSort( Lo, j );
    if i < Hi then
      QuickSort( i, Hi );
  end;

{ Output the result of the sort to the destination file }

  procedure WriteSortedFile;
  Var
    Winx    : Word;
    Check   : Word;
    Lf      : Char;
    p,pBuf  : PChar;
    Index   : Word;
    Len     : Longint;
    Increm  : Longint;

  begin
    Lf := #10;
    pBuf := InBuffer;

    Winx   := 0;
    Increm := 1;
    If ReverseOutput in Options then
      begin
        Winx   := Words-1;
        Increm := -1;
      end;

    While ( Winx < Words ) and ( Winx >= 0 ) do
      begin
        p := GetStringPtr( WInx, Len );

        Move( p^, pBuf^, Len );
        Inc( pBuf, Len );

        Move( Lf, pBuf^, 1 );
        Inc( pBuf );

        Inc( Winx, Increm );
      end;

    BlockWrite( OutFile, InBuffer^, SortSize, Check );
    If Check <> SortSize then
      raise ESort.Create('Error writing to output file');
  end;

  { Free the memory used by buffers, indices etc }

  procedure FreeMemory;
  begin
    FreeMem( SortIndex, WordInxLen );
    FreeMem( WordIndex, WordInxLen );
    FreeMem( InBuffer, InBufSize );
    FreeMem( OutBuffer, OutBufSize );
  end;

{ Top level sort routine.  Displays elapsed time for the parts }

begin
  TimerStart( 0,'Reading    '); ReadInFile;               TimerDisplay( 0 );
  TimerStart( 0,'Converting ');
  Words := ConvertBuffer( InBufSize, InBuffer, OutBuffer );
                                                          TimerDisplay( 0 );
  TimerStart( 0,'Indexing   '); GetStringIndex;           TimerDisplay( 0 );
  MeanLength := Round( SortSize / Words );

  TimerStart( 0,'Sorting    '); QuickSort( 0, Words-1 );  TimerDisplay( 0 );
  TimerStart( 0,'Writing    '); WriteSortedFile;          TimerDisplay( 0 );

  FreeMemory;

  Writeln;
  Writeln('--- ',Words,' lines were sorted');
end; // Sortfile

{ Main Program }

Var
  SourceFileName  : String;
  DestFileName    : String;
  InFile          : File;
  OutFile         : File;
  Options         : OptionSet;

begin
  WriteLn('Virtual Pascal Sort     Version 2.1 Copyright (C) 1995-2000 vpascal.com');

  try
    TimerStart( 1, '');
    Initialize( SourceFileName, DestFileName, Options );
    ParseParameters( SourceFileName, DestFileName, Options );

    Writeln;
    Writeln('--- Sorting ',SourceFileName );
    OpenFiles( SourceFileName, DestFileName, InFile, OutFile );

    SortFile( InFile, OutFile, Options );

    CloseFiles( InFile, OutFile );
    If GetLineLength in Options then
      begin
        Writeln('  + Longest Line is ',LongestWord,' characters');
        Writeln('  + Average length  ',MeanLength,' characters');
      end;
    Write('--- Total Time Used ');
    TimerDisplay( 1 );
  except
    on E:ESort do
      Writeln(#13'Fatal sort error: ',E.Message);
    on E:Exception do
      Writeln(#13'Error: ',E.Message);
  end;
end.


