(****************************************************************)
(*                     DATABASE TOOLBOX 4.0                     *)
(*     Copyright (c) 1984, 87 by Borland International, Inc.    *)
(*                                                              *)
(*                           TextSort                           *)
(*                                                              *)
(*  Sorts a text file using the Turbo Sort unit. The user       *)
(*  has the option to ignore case and specify which             *)
(*  columns to sort on.                                         *)
(*                                                              *)
(****************************************************************)
program TextSort;
uses
  Crt,
  Sort,
  MiscTool,
{ If a compiler error occurs here, you need to unpack the source
  to the MiscTool unit from the archived file Tools.arc.  See the
  README file on disk 1 for detailed instructions. }

  FileUtil,
  EditLn;

{$V-}
type
  MaxString = string[80];
     { Will only sort lines up to 80 characters }
  SortRec = record
              OrigStr,
             { The Original string which will be written to the output file. }
             SortStr : MaxString;
           { String that will be sorted on.  Note we set up these strings in
             the InputLines procedure which is only called once.  This method
             is much faster than taking the uppercase of the strings in each
             call to LessLine which is called many times. }
         end;
var
  InputF,
  OutputF : text;
  SRec       : SortRec;
  results,
  FromCol,
  ToCol : integer;
  IgnoreCase : boolean;

{$F+} { Force far calls.  Necessary for Turbo Sort to call the 3 }
      { user routines. }

procedure InputLines;
{ Inputs all of the lines from the text file converts them
  to sort strings and passing the SortRecord in to to be
  sorted.  This parameterless procedure is called once
  by Turbo Sort. }

procedure SpaceOut(var s : MaxString; FromCol, ToCol : byte);
{ Put spaces in columns we are not sorting on }
var
  i : byte;
begin
  for i := 1 to FromCol - 1 do
    s[i] := ' ';
  for i := ToCol + 1 to SizeOf(MaxString) - 1 do
    s[i] := ' ';
end; { SpaceOut }

var
  L : LongInt;

begin
  Reset(InputF);
  L := 0;
  Writeln('Reading');
  while not EOF(InputF) do
  begin
    if KeyPressed then Halt;
    Inc(L);
    if L MOD 10 = 0 then
      Write(#13, L:6);
    Readln(InputF, SRec.OrigStr);
    SRec.SortStr := SRec.OrigStr;
    if IgnoreCase then
      SRec.SortStr := UpCaseStr(SRec.SortStr);
    SpaceOut(SRec.SortStr, FromCol, ToCol);
    SortRelease(SRec);
  end;
  Writeln(#13, L:6);
  Writeln;
  Write('Sorting lines...');
end; { InputLines }

function LessLine(var FirstLine, SecondLine : SortRec) : boolean;
{ Returns true if the sort string of FirstLine is less than the
  sort string of SecondLine.  This function is called by Turbo Sort
  and must have two VAR parameters. }
begin
  LessLine := FirstLine.SortStr < SecondLine.SortStr;
end; { LessLine }

procedure OutputLines;
{ This parameterless procedure is called by Turbo Sort to output
  the sorted lines to the output text file }
var
  L : LongInt;
begin
  L := 0;
  Writeln;
  Writeln;
  Writeln('Writing');
  repeat
    if KeyPressed then Halt;
    Inc(L);
    if L MOD 50 = 0 then
      Write(#13, L:6);
    SortReturn(SRec);
    Writeln(OutputF, SRec.OrigStr);
  until SortEOS;
  Writeln(#13, L:6);
  Write(OutputF, ^Z);
  Close(OutputF);
end; { OutputLines }

{$F-} { Use near calls for other routines }

function GetFileName(var F : FileName;
                     ExistCheck: boolean) : boolean;
const
  Terminators : CharSet = [CR, Esc];
var
  SaveX,
  SaveY : byte;
  TC : Char;
  AllDone : boolean;

begin
  GetFileName := false;
  SaveX := WhereX; { Save Initial X coordinate }
  SaveY := WhereY;
  repeat
    EditLine(F, SizeOf(FileName) - 1, SaveX, SaveY,
             [#32..#127], Terminators, TC);
    case TC of
      CR : if ExistCheck then
             Alldone := Exist(F)
           else
             Alldone := true;
      Esc : Alldone := true;
    end;
    if not AllDone then
      Beep;
  until Alldone;
  GetFileName := TC <> Esc;
  Writeln;
end; { GetFileName }

procedure GetSortDefaults;
var
  ch : char;
begin
  Writeln;
  Write('Ignore upper/lower case? ');
  repeat
    ch := Upcase(ReadKey);
  until ch in [Esc, ^C, 'Y', 'N'];
  if ch in [Esc, ^C] then
    Abort('User terminated');
  IgnoreCase := UpCase(ch) = 'Y';
  if IgnoreCase then
    Writeln('Yes')
  else
    Writeln('No');
  FromCol := 1;
  Write('Starting sort column: ');
  Readln(FromCol);
  ToCol := SizeOf(MaxString) - 1;
  Write('Ending sort column:   ');
  Readln(ToCol);
  Writeln;
end; { GetSortDefaults }

procedure OpenFiles;
const
  OutExt = '.SRT';
var
  InFileName,
  OutFileName  : FileName;
  InFileSpec : FileSpec;
begin
  ClrScr;
  Write('Text file to be sorted: ');
  InFileName := '';
  if ParamCount >= 1 then
    InFileName := ParamStr(1);
  if (InFileName <> '') and Exist(InFileName) then
    Writeln(InFileName)
  else
    if not GetFileName(InFileName, true) then
      Abort('User Terminated');
  Assign(InputF, InFileName);
  Reset(InputF);
  Writeln;
  Write('Output file: ');
  OutFileName := '';
  if ParamCount >= 2 then
    OutFileName := ParamStr(2);
  if OutFileName = '' then
  begin
    GetFileSpec(InFileSpec, InFileName);
    with InFileSpec do
      OutFileName := Path + Name + OutExt;
    if not GetFileName(OutFileName, false) then
      Abort('User Terminated');
  end
  else
    Writeln(OutFileName);
  Assign(OutputF, OutFileName);
  {$I-}
  Rewrite(OutputF);
  if IOResult <> 0 then
    Abort('Could not create ' + OutFileName);
  {$I+}
end; { OpenFiles }

procedure DisplayResults(results : integer);
begin
  Writeln;
  Writeln;
  case Results of                           { display sort results }
     0 : Writeln('Done with sort and display.');
     3 : Writeln('Error:  not enough memory to sort');
     8 : Writeln('Error:  illegal item length.');
     9 : Writeln('Error:  can only sort ', MaxInt, ' records.');
    10 : Writeln('Error:  disk full or disk write error.');
    11 : Writeln('Error:  disk error during read.');
    12 : Writeln('Error:  directory full or invalid path name');
  end; { case }
end; { DisplayResults }

begin { program body }
  LowVideo;
  OpenFiles;
  GetSortDefaults;
  Results := TurboSort(SizeOf(SortRec), @InputLines, @LessLine, @OutputLines);
  DisplayResults(Results);                  { display sort results }
end.


