Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB36.ZIP/SORTER.PAS

Pascal/Delphi Source File | 1986-02-09 | 23.9 KB | 698 lines

(***************************************************************)
(*                                                             *)
(*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
(*                                                             *)
(*        (C) 1985 by  John M. Harlan                          *)
(*                     24000 Telegraph                         *)
(*                     Southfield, MI. 48034                   *)
(*                                                             *)
(*     The FILER GROUP of programs is released on a "FREE      *)
(*     SOFTWARE" basis.  The recipient is free to examine      *)
(*     and use the software with the understanding that if     *)
(*     the FILER GROUP of programs prove to be of use and      *)
(*     value,  a contribution to the author is encouraged.     *)
(*                                                             *)
(*     While reasonable effort has been made to ensure the     *)
(*     reliability of the FILER GROUP of programs, no war-     *)
(*     ranty is given. The recipient uses the programs at      *)
(*     his own risk  and in no event shall the author be       *)
(*     liable for damages arising from their use.              *)
(*                                                             *)
(*                                                             *)
(***************************************************************)


program sorter; { ONE OF THE FILER GROUP OF PROGRAMS }
{  PROGRAM TO SORT FILES CREATED BY THE FILER GROUP OF PROGRMS  }
{  SORTER.PAS  VERSION 2.0 }
{  INCLUDE FILES : SORT.BOX (PART OF TURBO TOOLBOX) }
{  APR 29, 1985 }

{ Formatted 2/7/86 by Doug Stevens using Pformat and the Turbo
  editors global search/replace. Original version was 100%
  upper case and very hard to read. }

label  QUIT;

type
  Range            = array[1..256] of char;
  String60         =  string[60];
  String20         =  string[20];
  NameStr          =  string[12];

var
  filerecchgd      : boolean;    { FOR SOURCE FILE }
  recaddedtofile   : boolean;    { FOR SOURCE FILE }
  filerecchgd2     : boolean;    { FOR DESTINATION FILE }
  recaddedtofile2  : boolean;    { FOR DESTINATION FILE }
  fileexists       : boolean;
  nullrecord       : boolean;
  exitflag         : boolean;

  ch               : char;

  filename         : string[6];
  filedate,
  currdate         : string[8];
  sourcename       : string[14];
  sourcenamedat    : string[14];
  sourcenamebak    : string[14];
  ans              : String60;
  message          : String60;
  thiskey          : String60;

  w, x, y, z, code, first, len,
  maxnbrrec, rcdlen,
  blockingfactor, fieldperrecord,
  ascii, keylength                      : integer;

  datarecord, diskrecord, precbyte,
  diskrecnowinmem, nbrdiskrecused,
  nbrrecused,lastrecused                : integer;  { FOR SOURCE FILE }

  datarecord2, diskrecord2, precbyte2,
  diskrecnowinmem2, nbrdiskrecused2,
  nbrrecused2,lastrecused2              : integer;  { FOR DESTINATION FILE }

  numvalue                              :    real;

  labellength, datalen, dataform,
  labelposn, dataposn, row,
  column                            :    array[1..32] of integer;
  keyfield                          :    array[0..10] of integer;
  lbl                               :    array[1..384] of char;
  getdata                           :    Range;  { FOR SOURCE FILE }
  outdata                           :    Range;  { FOR DESTINATION FILE }

  source                            :    file;
  destination                       :    file;

{$ISORT.BOX}           { include sort routine from turbo toolbox }

{================================================================}
{        BINARY CODED DECIMAL TO INTEGER FUNCTION                }
{================================================================}
function BcdToInt (cha : char) : integer;
begin
  BcdToInt := ord(cha) - trunc(ord(cha)/16)*6;
end;
{================================================================}
{             CHARACTER TO INTEGER FUNCTION                      }
{================================================================}
function ChrToInt(var charray : Range; start, len : integer)  : integer;
var
  code, result : integer;
  workstring   : string[10];
begin
  workstring := '';
  for result := 0 to len-1  do
    begin
      if charray[start + result ] = ' ' then
        workstring := workstring + '0'
      else workstring := workstring + charray[start+result];
    end;
  val(workstring,result,code);
  ChrToInt := result;
end;
{================================================================}
{               TIDE (EDIT BACKWARDS) PROCEDURE                  }
{================================================================}
procedure Tide( var message : String60);
var w  :  integer;
begin
  for w := length(message) downto 1 do
    begin
      if message[w] in [',', '$', '+'] then
        begin
          delete(message,w,1);
          message := ' ' + message;
        end;
    end;
end;
{===============================================================}
{                      FUNCTION EDITNBR                         }
{===============================================================}
function editnbr(x: real; y,z: integer; dollar: char ) : String20;
var
  numstring : string[24];
begin    { CONVERT THE REAL NUMBER TO A STRING VALUE }
  str(x:18:z,numstring);
  if z = 0 then z := 16  { FIRST POSSIBLE COMMA LOCATION  }
  else z := pos('.',numstring)-3;  {    DITTO             }

  while z > 1 do  {  INSERT COMMAS/SPACES IN THE NUMBER  }
    begin
      if numstring[z-1] in [' ','-'] then
        insert(' ',numstring,z)
      else insert(',',numstring,z);
      z := z -3 ;  {  COMMAS OCCUR EVERY THIRD CHARACTER  }
    end;

  {  FIND THE FIRST NON SPACE CHARACTER IN THE NUMBER }
  z := 0;
  repeat
    z := z + 1;
 until numstring[z] <> ' ';

  { DELETE ANY SPACE FOLLOWING A MINUS SIGN }
  if numstring[z] = '-' then
    begin
      if numstring[z+1] = ' ' then delete(numstring,z+1,1);
      if dollar = '$' then insert('$',numstring,z+1);
    end

  { ADD THE $/SPACE CHARACTER TO THE BEGINNING OF THE NUMBER }
  else numstring[z-1] := dollar;

  { REPLACE THE NUMBER WITH A FIELD OF '<' IF IT IS TOO BIG  }
  z := length(numstring)-y;
  if numstring[z-1] = '-' then
      for z := y downto 0 do numstring[z] := '<'
  else
    begin
      if numstring[z] in ['0'..'9',',','-','.'] then
          for z := y downto 0 do numstring[z] := '<';
    end;
  editnbr := copy(numstring,z+1,y);

end;
{================================================================}
{               STRING TO REAL NUMBER PROCEDURE                  }
{================================================================}
procedure StringToReal(var source:String60;var numb:real;var code:integer);
var
  w  :  integer;
  condition  :  boolean;
begin
  w := 1;
  numb := 0;
  condition := true;
  Tide(source); { ELIMINATE PUNCTUATION }
  repeat  { UNTIL CONDITION = FALSE }
    if source[w] = ' ' then delete(source,1,1)
    else condition := false;
    if length(source) = 0 then
      begin
        source := '0';
        condition := false;
      end;
  until condition = false;
  if length(source) = 1 then condition := true;
  while condition = false do
    begin
      if source[w] = ' ' then
        begin
          condition := true;
          w := w-2;
        end;
      if length(source) = w then
        begin
          condition := true;
          w := w-1;
        end;
      w := w + 1;
    end;
  source := copy(source,1,w);
  val( source,numb,code );
end;
{================================================================}
{           CALCULATE DISKRECORD & PRECBYTE PROCEDURE            }
{================================================================}
procedure Calculate;
  begin
    diskrecord := trunc((datarecord-1)/blockingfactor)*2+7;
    precbyte := ((datarecord-1) mod blockingfactor)*rcdlen;
  end;
{================================================================}
{                   GET DATA RECORD PROCEDURE                    }
{================================================================}
procedure GetDataRec;
  begin
    Calculate;
    if diskrecord <> diskrecnowinmem then
      begin
        if filerecchgd = true then
          begin
            if diskrecnowinmem > nbrdiskrecused then
              begin                 { GET NEXT AVAILABLE RECORD }
                Seek(source,nbrdiskrecused+2);
                nbrdiskrecused := diskrecnowinmem;
              end
            else
              begin
                Seek(source,diskrecnowinmem);
              end;
            blockwrite(source,getdata,2);  {SAVE CHANGED DATA}
            filerecchgd := false;
          end;
        if diskrecord <= nbrdiskrecused then
          begin
            Seek(source,diskrecord);
            blockread(source,getdata,2);         {  RECORD DATA  }
          end
        else FillChar(getdata[1],256,' '); {SPACES FOR EMPTY REC }
        diskrecnowinmem := diskrecord;
      end;
  end;
{================================================================}
{     CALCULATE DESTINATION DISKRECORD & PRECBYTE PROCEDURE      }
{================================================================}
procedure Calculate2;
  begin
    diskrecord2 := trunc((datarecord2-1)/blockingfactor)*2+7;
    precbyte2 := ((datarecord2-1) mod blockingfactor)*rcdlen;
  end;
{================================================================}
{            GET DESTINATION DATA RECORD PROCEDURE               }
{================================================================}
procedure GetDataRec2;
  begin
    Calculate2;
    if diskrecord2 <> diskrecnowinmem2 then
      begin
        if filerecchgd2 = true then
          begin
            if diskrecnowinmem2 > nbrdiskrecused2 then
              begin                 { GET NEXT AVAILABLE RECORD }
                Seek(destination,nbrdiskrecused2+2);
                nbrdiskrecused2 := diskrecnowinmem2;
              end
            else
              begin
                Seek(destination,diskrecnowinmem2);
              end;
            blockwrite(destination,outdata,2);  {SAVE CHANGED DATA}
            filerecchgd2 := false;
          end;
        if diskrecord2 <= nbrdiskrecused2 then
          begin
            Seek(destination,diskrecord2);
            blockread(destination,outdata,2);         {  RECORD DATA  }
          end
        else FillChar(outdata[1],256,' '); {SPACES FOR EMPTY REC }
        diskrecnowinmem2 := diskrecord2;
      end;
  end;
{================================================================}
{               GET DATA FROM ARRAY PROCEDURE                    }
{================================================================}
procedure GetDataFromArray(var message : String60; z : integer);
var w :  integer;
begin
  message := '';
  for w := precbyte+dataposn[z] to precbyte+dataposn[z+1]-1 do
    message := message + getdata[w];
end;
{================================================================}
{                      PROCEDURE INP                             }
{================================================================}
procedure Inp;
begin
  writeln('BUILD KEY FIELDS FOR SORT');
  writeln;
  for datarecord := 1 to nbrrecused do
    begin
      Calculate;
      GetDataRec;
      nullrecord := true;
      y := 1;
      while ( y <= rcdlen) and ( nullrecord = true) do
        begin
          if getdata[precbyte+y] <> ' ' then nullrecord := false;
          y := y+1;
        end;
      if nullrecord = true then nbrrecused := nbrrecused -1
      else
        begin                {  BUILD KEY FIELD FOR SORT  }
          thiskey := '';
          for z := 1 to keyfield[0] do
            begin
              GetDataFromArray(ans,keyfield[z]);
              thiskey := thiskey + ans;
            end;
          str(datarecord:5,ans);
          if length(thiskey)>55 then
            thiskey := copy(thiskey,1,55);
          thiskey := thiskey + ans ;
          writeln(thiskey,'  ');
         sortrelease(thiskey);
       end;
    end;
  writeln;
  writeln;
  writeln('DATA INPUT COMPLETED');
  writeln;
  writeln;
  writeln('..oO[  SORTING  ]Oo..');
  writeln;
end;
{================================================================}
{                       FUNCTION LESS                            }
{================================================================}
function Less;
var
  firststring  :  String60 Absolute x;
  secondstring :  String60 Absolute y;
begin
  Less := firststring < secondstring;
end;
{================================================================}
{                       PROCEDURE OUTP                           }
{================================================================}
procedure Outp;
begin
writeln;
writeln('..oO[  KEY SORT DONE  ]Oo..');
writeln;
writeln;
writeln('..oO[  MOVING RECORDS  ]Oo..');
writeln;
writeln;
  for datarecord2 := 1 to nbrrecused do
    begin
      sortreturn(thiskey);
      ans := copy(thiskey,keylength-4,5);
      for w := 1 to 5  do
        if ans[w] =' ' then ans[w] := '0';
      val(ans,datarecord,code);
      GetDataRec;  { GET SOURCE RECORD }
      GetDataRec2; { GET DESTINATION RECORD }
      for w := 1 to rcdlen do
        outdata[precbyte2+w] := getdata[precbyte+w];
      filerecchgd2 := true;
      GotoXY(1,23);
      write('   RECORD ',datarecord2,' OF ',nbrrecused,' MOVED.');
    end;
    GotoXY(1,23);
    ClrEol;
    writeln;
  if filerecchgd2 = true then
    begin                            { WRITE LAST CHANGED RECORD }
      Seek(destination,diskrecnowinmem2);
      blockwrite(destination,outdata,2)
    end;
  writeln;
  writeln('..oO[  RECORDS MOVED  ]Oo..');
  writeln;
  writeln;
end;
{================================================================}
{                 PRINT LABEL AND FIELD NUMBER                   }
{================================================================}
procedure PrintLabFldNbr( z: integer);
var
  w      :  integer;
begin
  if row[z] <22 then
    begin
      GotoXY(column[z],row[z]);
      for w := labelposn[z] to labelposn[z+1]-1 do
      write (lbl[w]);
      write('= ',z);
    end;
end;
{================================================================}
{                      PRINT LABEL                               }
{================================================================}
procedure PrintLabel( z: integer);
var
  w      :  integer;
begin
  write(z,' : ');
  for w := labelposn[z] to labelposn[z+1]-1 do
  write (lbl[w]);
  writeln;
end;
{================================================================}
{                 DISPLAY ONE RECORD PROCEDURE                   }
{================================================================}
procedure DisplayRec;
begin
  ClrScr;
  for z := 1 to fieldperrecord do
  PrintLabFldNbr(z);
  GotoXY(70,23);
  write('RECORD ',datarecord);
  lastrecused := datarecord;
end;
{===============================================================}
{                       FUNCTION EXIST                          }
{===============================================================}
function Exist(filename : NameStr) : boolean;
var
  fil    :  file;
  status : Integer;
begin
  Assign(fil,filename);
  {$I-}
  reset(fil);
  {$I+}
  Exist := (IOResult = 0);
{$I-} Close(fil); status := IOResult; {$I+} (* Required by Turbo 3.x *)
end;                                        (* Added by Doug Stevens *)
{================================================================}
{           FUNCTION GET NUMBER IN GETDATA FIELD ( Z )           }
{================================================================}
function FnbrInFld(z : integer) : real;
var
  realval : real;
  begin
    GetDataFromArray(ans,z);
    if dataform[z] <> ascii then
      StringToReal(ans,realval,code)
    else realval := 0;
    FnbrInFld := realval;
  end;

{================================================================}
{                  INITIALIZE FILER FILE                         }
{================================================================}
procedure Initialize;

  label QUIT;

begin
  repeat
    ClrScr; exitflag := FALSE;
    TextMode(bw40);
    GotoXY(1,22);
    write('SORTER A LA PASCAL');
    GotoXY(1,23);
    write('ENTER SOURCE FILE NAME : ');
    readln(sourcename);
    x := pos('.',sourcename);
    if x <> 0 then sourcename := copy(sourcename,1,x-1);
    if (sourcename = 'END') then
      begin                      { Quick & dirty exit. }
        exitflag := TRUE;
        goto QUIT;
      end;
    sourcenamedat := sourcename + '.DAT';
    sourcenamebak := sourcename + '.BAK';
    fileexists := Exist(sourcenamedat);
  until fileexists = true;

  {========================================}
  {   ERASE ANY BACKUP FILE OF SAME NAME   }
  {========================================}
  if (Exist(sourcenamebak)) then
    begin
      Assign(source,sourcenamebak);
      Erase(source);
      writeln;
      writeln(sourcenamebak,' HAS BEEN DELETED.');
    end;

  {========================================}
  {       RENAME FILE TO FILENAME.BAK      }
  {========================================}
  Assign(source,sourcenamedat);
  Rename(source,sourcenamebak);
  reset(source);
  writeln('FILE ',sourcenamedat,' RENAMED ',sourcenamebak);

  {=======================================}
  {    CREATE DESTINATION FILENAME.DAT    }
  {=======================================}
  Assign(destination, sourcenamedat);
  rewrite ( destination );

  {=======================================}
  {      BUILD HEADER FOR NEW FILE        }
  {=======================================}
  Seek(source,0);
  blockread( source,getdata,1 );          { BASIC/Z BLOCK 0 }
  blockwrite(destination,getdata,1);

  blockread( source,getdata,1 );          { FILE PARAMETERS }
  blockwrite(destination,getdata,1);

  blockread( source,lbl,3 );                 { FILER LABELS }
  blockwrite(destination,lbl,3);


  {=================================================}
  {      READ IN HEADER DATA FOR FILER FILE         }
  {=================================================}
  filename := 'XXXXXX';
  for x := 1 to 6 do
    filename[x] := getdata[x];
  maxnbrrec := ChrToInt(getdata,7,4);
  nbrrecused := ChrToInt(getdata,11,4);
  rcdlen := ChrToInt(getdata,15,3);
  blockingfactor := ChrToInt(getdata,18,2);
  fieldperrecord := ChrToInt(getdata,20,2);
  filedate := '  /  /  ';
  Move(getdata[22],filedate[1],8);

{================================================================}
{  GET LABEL LENGTH, DATA LENGTH & DATA FORM INFO                }
{================================================================}

labelposn[1] := 1;
dataposn[1] := 1;

for x := 1 to fieldperrecord do
  begin
    labellength[x] :=  BcdToInt(getdata[32+x]);
    datalen[x]     :=  BcdToInt(getdata[64+x]);
    dataform[x]    :=  ord(getdata[96+x])-48;
    labelposn[x+1] :=  labelposn[x] + labellength[x];
    dataposn[x+1]  :=  dataposn[x] + datalen[x];
  end;

{================================================================}
{           TRANSLATE REPORT STRUCTURE                           }
{================================================================}

  blockread(source,getdata,1);  { SCREEN INFORMATION }
  blockwrite(destination,getdata,1);
      { ESTABLISH VALUE OF DATAFORM[Z] FOR ASCII INFORMATION }
      if getdata[1] = 'S' then ascii := 9 else ascii := 15;
  for x := 1 to fieldperrecord do
    begin
      w := x*4+1;
      row[x]       := BcdToInt(getdata[w]);
      column[x] := BcdToInt(getdata[w+1])*10+trunc(BcdToInt(getdata[w+2])/10);
      {FIELDNBR[X]  := BCDTOIN(GETDATA[W+3]);} { not implemented }
    end;
  blockread(source,getdata,2);  { REPORT FORMAT INFORMATION (NOT USED) }
  blockwrite(destination,getdata,1);
  blockwrite(destination,getdata,1);    { FIRST RECORD GOES HERE }
  blockwrite(destination,getdata,1);

{================================================================}
{          INITIALIZE VARIABLES FOR ENTRY INTO FILER             }
{================================================================}
  datarecord := nbrrecused;                 { SOURCE FILE SET UP }
  Calculate;
  diskrecnowinmem := diskrecord -1; { ENSURE DISK READ FIRST TIME}
  filerecchgd := false;      { ENSURE NO WRITE BEFORE FIRST READ }
  lastrecused := 0;               { SET LAST RECORD USED TO ZERO }
  nbrdiskrecused := diskrecord;     { ESTABLISH MAX DISK REC NBR }
  recaddedtofile := false; { FLAG TO INDICATE CHANGE IN FILE SIZE}

  nbrrecused2 := 0;                    { DESTINATION FILE SET UP }
  datarecord2 := nbrrecused2;
  Calculate2;
  diskrecnowinmem2 := diskrecord2 -1; { ENSURE DISK READ FIRST TIME}
  filerecchgd2 := false;       { ENSURE NO WRITE BEFORE FIRST READ }
  lastrecused2 := 0;                { SET LAST RECORD USED TO ZERO }
  nbrdiskrecused2 := diskrecord2;     { ESTABLISH MAX DISK REC NBR }
  recaddedtofile2 := false;  { FLAG TO INDICATE CHANGE IN FILE SIZE}
QUIT:
end;  { INTIIALIZE PROCEDURE }


{================================================================}
{                         SORT PROGRAM                           }
{================================================================}

begin
  Initialize;                   { ID AND READ IN FILE PARAMETERS }
  if exitflag then goto QUIT;   { Quick and dirty exit. }
  TextMode(bw80);

  {======================================}
  {           ENTER KEY FIELDS           }
  {======================================}
  repeat
    DisplayRec;
    GotoXY(1,21);
    write('IN ORDER OF IMPORTANCE :');
    x := 1;
    keylength := 0;
    repeat
      ClrEol;
      if x = 1 then
        begin
          GotoXY(1,23);
          write('ENTER KEY FIELD NUMBER : ')
        end
      else
        begin
          GotoXY(1,24);
          write('ENTER RETURN ONLY TO END KEY DEFINITION');
          GotoXY(1,23);
          write('ENTER NEXT KEY FIELD : ');
          ClrEol;
        end;
      ans := '';
      read(ans);
      StringToReal(ans,numvalue,code);
      keyfield[x] := trunc(numvalue);
      if numvalue <> 0 then keylength := keylength + datalen[keyfield[x]];
      x := x + 1;
    until numvalue = 0;
    keyfield[0] := x-2;
    if keylength > 55 then keylength := 55;
    keylength := keylength + 6;  { 5 for field nbr + 1 for string 0 byte }

    {=======================================}
    {      DISPLAY KEYS SELECTED            }
    {=======================================}
    ClrScr;
    GotoXY(1,23);
    writeln('KEY FIELDS SELECTED ARE :');
    writeln('=========================');
    writeln;
    for x := 1 to keyfield[0] do
      begin
        PrintLabel(keyfield[x]);
      end;
    writeln;
    writeln('=========================');
    writeln('KEYLENGTH = ',keylength);
    write('IS THIS OK (Y/N) : ');
    readln(ch);
  until (UpCase(ch) = 'Y') or (eoln);
  writeln;

  {===============================================}
  {  BUILD KEY FIELDS AND PASS TO TURBO SORT      }
  {===============================================}

  writeln(turbosort(keylength)); { CALL TURBO SORT PROGRAM }
                                 { SEE INP, LESS & OUTP    }
                                 { PROCEDURES              }

{================================================================}
{                    END PROGRAM                                 }
{================================================================}

  Seek(destination,1);
  blockread(destination,getdata,1);
  str(nbrrecused:4,ans);
  Move(ans[1],getdata[11],4);  { UPDATE NBR OF RECORDS }
  Seek(destination,1);
  blockwrite(destination,getdata,1);
  close(source);
  close(destination);
  GotoXY(5,24);
  writeln('[  0 INDICATES SUCCESSFUL SORT  ]');
  writeln;
  writeln;
  writeln('..oO[   HAVE A GREAT DAY!   ]Oo..');
QUIT:
end.