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

Pascal/Delphi Source File | 1985-11-18 | 15.6 KB | 458 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 : SORTER1.PAS, SORT.BOX (PART OF TURBO TOOLBOX) }
{  APR 29, 1985 }

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;

  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 BCDTOIN (CHA : CHAR) : INTEGER;
BEGIN
  BCDTOIN := ORD(CHA) - TRUNC(ORD(CHA)/16)*6;
END;
{================================================================}
{             CHARACTER TO INTEGER FUNCTION                      }
{================================================================}
FUNCTION CHTOIN(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);
  CHTOIN := 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;
BEGIN
  ASSIGN(FIL,FILENAME);
  {$I-}
  RESET(FIL);
  {$I+}
  EXIST := (IORESULT = 0)
END;
{================================================================}
{           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;
{$ISORTER1.PAS}