program dbfiles;

    label
        stop;

    type
        AnyString = string [255];
        FileName = string [11];

    var
        NEW_FILE_NAME, File_Name: string [11];

        f, f1, f2: Text;

        NL, Line: string [255];
        X1, z, i, j, k, SpaceCount: integer;
        ch: char;
        texton: boolean;
        Get_File: string [11];


    function Exist(FileN: Anystring): boolean;

        var
            F: file;
        begin
            {$I-}
            assign(F, FileN);
            reset(F);
            {$I+}
            if IOResult <> 0 then
                Exist := false
            else
                Exist := true;
        end;


    Procedure Check_It;
        begin
            NL := '';
            j := 0;
            if (copy(line, 1, 4) = 'STOR') then
                begin
                NL := NL + 'STORE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'ENDI') then
                begin
                NL := NL + 'ENDIF';
                j := 4;
                end
            else if (Copy(line, 1, 9) = 'APPE BLAN') then
                begin
                NL := NL + 'APPEND BLANK';
                j := 9;
                end
            else if (Copy(line, 1, 4) = 'ACCE') then
                begin
                NL := NL + 'ACCEPT';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'DELE') then
                begin
                NL := NL + 'DELETE';
                J := 4;
                end
            else if (copy(line, 1, 4) = 'ENDC') then
                begin
                NL := NL + 'ENDCASE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'ENDD') then
                begin
                NL := NL + 'ENDDO';
                j := 4;
                end
            else if (copy(line, 1, 7) = 'DO WHIL') then
                begin
                NL := NL + 'DO WHILE';
                j := 7;
                end
            else if (copy(line, 1, 4) = 'ERAS') then
                begin
                NL := NL + 'ERASE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'CANC') then
                begin
                NL := NL + 'CANCEL';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'CLEA') then
                begin
                NL := NL + 'CLEAR';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'CONT') then
                begin
                NL := NL + 'CONTINUE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'DISP') then
                begin
                NL := NL + 'DISPLAY';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'EJEC') then
                begin
                NL := NL + 'EJECT';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'INPU') then
                begin
                NL := NL + 'INPUT';
                j := 4
                end
            else if (copy(line, 1, 4) = 'RELE') then
                begin
                NL := NL + 'RELEASE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'DELE') then
                begin
                NL := NL + 'DELETE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'LOCA') then
                begin
                NL := NL + 'LOCATE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'RETU') then
                begin
                NL := NL + 'RETURN';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'REPL') then
                begin
                NL := NL + 'REPLACE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'REST') then
                begin
                NL := NL + 'RESTORE';
                j := 4;
                end
            else if (copy(line, 1, 9) = 'SELE PRIM') then
                begin
                NL := NL + 'SELECT PRIMARY';
                j := 9;
                end
            else if (copy(line, 1, 9) = 'SELE SECO') then
                begin
                NL := NL + 'SELECT SECONDARY';
                j := 9;
                end
            else if (copy(line, 1, 4) = 'CHAN') then
                begin
                NL := NL + 'CHANGE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'COUN') then
                begin
                NL := NL + 'COUNT';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'INSE') then
                begin
                NL := NL + 'INSERT';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'RECA') then
                begin
                NL := NL + 'RECALL';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'RELE') then
                begin
                NL := NL + 'RELEASE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'REPO') then
                begin
                NL := NL + 'REPORT';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'BROW') then
                begin
                NL := NL + 'BROWSE';
                j := 4;
                end
            else if (copy(line, 1, 4) = 'RESE') then
                begin
                NL := NL + 'RESET';
                j := 4;
                end
            else if (copy(line, 1, 7) = 'TOTA ON') then
                begin
                NL := NL + 'TOTAL ON';
                j := 7;
                end
            else if (copy(line, 1, 9) = 'UPDA FROM') then
                begin
                NL := NL + 'UPDATE FROM';
                j := 9;
                end;
            for i := j + 1 to length(line) do
                NL := NL + line[i];
            line := NL;
        end;


    Procedure Offset;

        var
            tempcount: integer;

        begin
            tempcount := 0;
            while tempcount < Spacecount do
                begin
                write(f1, ' ');
                tempcount := tempcount + 1;
                end;
        end;


    Procedure PrintLine;
        begin
            if not texton then
                Offset;
            writeln(f1, line);
            if (copy(line, 1, 4) = 'TEXT') or (copy(line, 1, 4) = 'text') or
               (copy(line, 1, 4) = 'Text') then
                texton := true;
        end;


    procedure expand_files;
        var
            line_count : integer;

        begin
            line_count:=0;
            ClrScr;
            writeln('Expanding line number: ');
            Assign(f, File_Name + '.PRG');
            ReSet(f);
            Assign(f1, File_Name + '.NEW');
            Rewrite(f1);
            Texton := false;
            SpaceCount := 0;
            While not Eof(f) do
                begin
                readln(f, Line);
                line_count:=line_count+1;
                write(line_count:4);
                Check_it;

                if (copy(line, 1, 4) = 'ENDT') or (copy(line, 1,
                   4) = 'endt') or (copy(line, 1, 7) = 'Endtext') or
                   (copy(line, 1, 7) = 'ENDTEXT') or (copy(line, 1,
                   7) = 'EndText') or (copy(line, 1, 7) = 'endtext') then
                    texton := false;
                if copy(line, 1, 4) = 'CASE' then
                    begin
                    Offset;
                    writeln(f1, '*');
                    end;

                if (copy(line, 1, 7) = 'DO WHIL') or (copy(line, 1,
                   2) = 'IF') or (copy(line, 1, 7) = 'DO CASE') then
                    begin
                    Offset;
                    SpaceCount := SpaceCount + 2;
                    writeln(f1, line);
                    end

                else if (copy(line, 1, 4) = 'ENDC') or (copy(line, 1,
                        4) = 'ENDD') or (copy(line, 1, 4) = 'ENDI') then
                    begin
                    SpaceCount := SpaceCount - 2;
                    Offset;
                    writeln(f1, line);
                    end

                else if copy(line, 1, 4) = 'ELSE' then
                    begin
                    SpaceCount := SpaceCount - 2;
                    Offset;
                    Writeln(f1, line);
                    SpaceCount := SpaceCount + 2;
                    end

                else
                    PrintLine;
                end;
            close(f);
            close(f1);
            writeln;
            write(chr(7));
            writeln;
            writeln('Your original file is stored as ',File_Name,'.PRG');
            writeln('The expanded file  is stored as ',File_Name,'.NEW');
            writeln;
            write('Press [RETURN] to continue...');
            read(kbd,ch);
        end;


    procedure compress_files;

        label
            start;

        var
            temp_file: string [12];
            NL: string [255];
            quote: boolean;
            texton: boolean;
            line_count : integer;

        Procedure CheckIt;
            begin
                if (copy(line, j, 5) = 'store') or (copy(line, j,
                   5) = 'STORE') then
                    begin
                    NL := NL + 'STOR';
                    j := j + 5;
                    end
                else if copy(line, j, 2) = 'if' then
                    begin
                    NL := NL + 'IF';
                    j := j + 2;
                    end
                else if (copy(line, j, 5) = 'endif') or (copy(line, j,
                        5) = 'ENDIF') then
                    begin
                    NL := NL + 'ENDI';
                    j := j + 5;
                    end
                else if copy(line, j, 3) = 'set' then
                    begin
                    NL := NL + 'SET';
                    j := j + 3;
                    end
                else if copy(line, j, 4) = 'case' then
                    begin
                    NL := NL + 'CASE';
                    j := j + 4;
                    end
                else if (Copy(line, j, 12) = 'append blank') or (Copy(line, j,
                        12) = 'APPEND BLANK') then
                    begin
                    NL := NL + 'APPE BLAN';
                    j := j + 12;
                    end
                else if (Copy(line, j, 6) = 'accept') or (Copy(line, j,
                        6) = 'ACCEPT') then
                    begin
                    NL := NL + 'ACCE';
                    j := j + 6;
                    end
                else if (copy(line, j, 6) = 'delete') or (copy(line, j,
                        6) = 'DELETE') then
                    begin
                    NL := NL + 'DELE';
                    J := J + 6;
                    end
                else if copy(line, j, 4) = 'edit' then
                    begin
                    NL := NL + 'EDIT';
                    j := j + 4;
                    end
                else if (copy(line, j, 7) = 'endcase') or (copy(line, j,
                        7) = 'ENDCASE') then
                    begin
                    NL := NL + 'ENDC';
                    j := j + 7;
                    end
                else if (copy(line, j, 5) = 'enddo') or (copy(line, j,
                        5) = 'ENDDO') then
                    begin
                    NL := NL + 'ENDD';
                    j := j + 5;
                    end
                else if (copy(line, j, 8) = 'do while') or (copy(line, j,
                        8) = 'DO WHILE') then
                    begin
                    NL := NL + 'DO WHIL';
                    j := j + 8;
                    end
                else if (copy(line, j, 5) = 'erase') or (copy(line, j,
                        5) = 'ERASE') then
                    begin
                    NL := NL + 'ERAS';
                    j := j + 5;
                    end
                else if (copy(line, j, 6) = 'cancel') or (copy(line, j,
                        6) = 'CANCEL') then
                    begin
                    NL := NL + 'CANC';
                    j := j + 6;
                    end
                else if (copy(line, j, 5) = 'clear') or (copy(line, j,
                        5) = 'CLEAR') then
                    begin
                    NL := NL + 'CLEA';
                    j := j + 5;
                    end
                else if (copy(line, j, 8) = 'continue') or (copy(line, j,
                        8) = 'CONTINUE') then
                    begin
                    NL := NL + 'CONT';
                    j := j + 8;
                    end
                else if (copy(line, j, 7) = 'display') or (copy(line, j,
                        7) = 'DISPLAY') then
                    begin
                    NL := NL + 'DISP';
                    j := j + 7;
                    end
                else if copy(line, j, 4) = 'else' then
                    begin
                    NL := NL + 'ELSE';
                    j := j + 4;
                    end
                else if (copy(line, j, 5) = 'eject') or (copy(line, j,
                        5) = 'EJECT') then
                    begin
                    NL := NL + 'EJEC';
                    j := j + 5;
                    end
                else if (copy(line, j, 5) = 'input') or (copy(line, j,
                        5) = 'INPUT') then
                    begin
                    NL := NL + 'INPU';
                    j := j + 5;
                    end
                else if (copy(line, j, 7) = 'release') or (copy(line, j,
                        7) = 'RELEASE') then
                    begin
                    NL := NL + 'RELE';
                    j := j + 7;
                    end
                else if copy(line, j, 7) = 'do case' then
                    begin
                    NL := NL + 'DO CASE';
                    j := j + 7;
                    end
                else if (copy(line, j, 6) = 'delete') or (copy(line, j,
                        6) = 'DELETE') then
                    begin
                    NL := NL + 'DELE';
                    j := j + 6;
                    end
                else if copy(line, j, 4) = 'find' then
                    begin
                    NL := NL + 'FIND';
                    j := j + 4;
                    end
                else if copy(line, j, 4) = 'goto' then
                    begin
                    NL := NL + 'GOTO';
                    j := j + 4;
                    end
                else if copy(line, j, 4) = 'pack' then
                    begin
                    NL := NL + 'PACK';
                    j := j + 4;
                    end
                else if (copy(line, j, 6) = 'locate') or (copy(line, j,
                        6) = 'LOCATE') then
                    begin
                    NL := NL + 'LOCA';
                    j := j + 6;
                    end
                else if copy(line, j, 4) = 'loop' then
                    begin
                    NL := NL + 'LOOP';
                    j := j + 4;
                    end
                else if copy(line, j, 4) = 'skip' then
                    begin
                    NL := NL + 'SKIP';
                    j := j + 4;
                    end
                else if (copy(line, j, 6) = 'return') or (copy(line, j,
                        6) = 'RETURN') then
                    begin
                    NL := NL + 'RETU';
                    j := j + 6;
                    end
                else if (copy(line, j, 7) = 'replace') or (copy(line, j,
                        7) = 'REPLACE') then
                    begin
                    NL := NL + 'REPL';
                    j := j + 7;
                    end
                else if (copy(line, j, 7) = 'restore') or (copy(line, j,
                        7) = 'RESTORE') then
                    begin
                    NL := NL + 'REST';
                    j := j + 7;
                    end
                else if (copy(line, j, 14) = 'select primary') or (copy(line,
                        j, 14) = 'SELECT PRIMARY') then
                    begin
                    NL := NL + 'SELE PRIM';
                    j := j + 14;
                    end
                else if (copy(line, j, 16) = 'select secondary') or
                        (copy(line, j, 16) = 'SELECT SECONDARY') then
                    begin
                    NL := NL + 'SELE SECO';
                    j := j + 16;
                    end
                else if copy(line, j, 3) = 'use' then
                    begin
                    NL := NL + 'USE';
                    j := j + 3;
                    end
                else if (copy(line, j, 6) = 'change') or (copy(line, j,
                        6) = 'CHANGE') then
                    begin
                    NL := NL + 'CHAN';
                    j := j + 6;
                    end
                else if (copy(line, j, 5) = 'count') or (copy(line, j,
                        5) = 'COUNT') then
                    begin
                    NL := NL + 'COUN';
                    j := j + 5;
                    end
                else if (copy(line, j, 6) = 'insert') or (copy(line, j,
                        6) = 'INSERT') then
                    begin
                    NL := NL + 'INSE';
                    j := j + 6;
                    end
                else if copy(line, j, 4) = 'list' then
                    begin
                    NL := NL + 'LIST';
                    j := j + 4;
                    end
                else if copy(line, j, 4) = 'quit' then
                    begin
                    NL := NL + 'QUIT';
                    j := j + 4;
                    end
                else if copy(line, j, 4) = 'read' then
                    begin
                    NL := NL + 'READ';
                    j := j + 4;
                    end
                else if (copy(line, j, 6) = 'recall') or (copy(line, j,
                        6) = 'RECALL') then
                    begin
                    NL := NL + 'RECA';
                    j := j + 6;
                    end
                else if (copy(line, j, 7) = 'release') or (copy(line, j,
                        7) = 'RELEASE') then
                    begin
                    NL := NL + 'RELE';
                    j := j + 7;
                    end
                else if (copy(line, j, 6) = 'report') or (copy(line, j,
                        6) = 'REPORT') then
                    begin
                    NL := NL + 'REPO';
                    j := j + 6;
                    end
                else if copy(line, j, 4) = 'wait' then
                    begin
                    NL := NL + 'WAIT';
                    j := j + 4;
                    end
                else if (copy(line, j, 6) = 'browse') or (copy(line, j,
                        6) = 'BROWSE') then
                    begin
                    NL := NL + 'BROW';
                    j := j + 6;
                    end
                else if (copy(line, j, 5) = 'reset') or (copy(line, j,
                        5) = 'RESET') then
                    begin
                    NL := NL + 'RESE';
                    j := j + 5;
                    end
                else if copy(line, j, 7) = 'save to' then
                    begin
                    NL := NL + 'SAVE TO';
                    j := j + 7;
                    end
                else if copy(line, j, 7) = 'copy to' then
                    begin
                    NL := NL + 'COPY TO';
                    j := j + 7;
                    end
                else if (copy(line, j, 8) = 'total on') or (copy(line, j,
                        8) = 'TOTAL ON') then
                    begin
                    NL := NL + 'TOTA ON';
                    j := j + 8;
                    end
                else if copy(line, j, 3) = 'sum' then
                    begin
                    NL := NL + 'SUM';
                    j := j + 3;
                    end
                else if copy(line, j, 7) = 'sort to' then
                    begin
                    NL := NL + 'SORT TO';
                    j := j + 7;
                    end
                else if copy(line, j, 7) = 'join to' then
                    begin
                    NL := NL + 'JOIN TO';
                    j := j + 7;
                    end
                else if (copy(line, j, 11) = 'update from') or (copy(line, j,
                        11) = 'UPDATE FROM') then
                    begin
                    NL := NL + 'UPDA FROM';
                    j := j + 11;
                    end
                else if copy(line, j, 2) = 'do' then
                    begin
                    NL := NL + 'DO';
                    j := j + 2;
                    end;
            end;


        Procedure PrintLine;
            begin
                for i := j to length(line) do
                    NL := NL + line[i];
            end;


        Procedure IsSpace;
            begin
                if (line[i + 1] = '<') or (line[i + 1] = '>') or
                   (line[i + 1] = '=') or (line[i + 1] = '+') or
                   (line[i + 1] = '-') or (line[i + 1] = '*') or
                   (line[i + 1] = '/') or (line[i + 1] = ',') then
                    i := i + 1
                else if (line[i - 1] = '<') or (line[i - 1] = '>') or
                        (line[i - 1] = '=') or (line[i - 1] = '+') or
                        (line[i - 1] = '-') or (line[i - 1] = '*') or
                        (line[i - 1] = '/') or (line[i - 1] = ',') then
                    i := i + 1;
            end;


        Procedure CommandLine;
            begin
                i := j;
                quote := false;
                while i <= length(line) do
                    begin
                    if (quote = false) and (line[i] = chr(34)) then
                        quote := true
                    else if (quote = false) and (line[i] = chr(39)) then
                        quote := true
                    else if (quote = true) and (line[i] = chr(34)) then
                        quote := false
                    else if (quote = true) and (line[i] = chr(39)) then
                        quote := false;
                    if (quote = false) and (line[i] = chr(32)) then
                        IsSpace;
                    NL := NL + line[i];
                    i := i + 1;
                    end;
            end;

        begin
            ClrScr;
            line_count:=0;
            writeln('Compressing line number: ');
            texton := false;
            Assign(f, File_Name + '.PRG');
            ReSet(f);
            Assign(f1, File_Name + '.HLD');
            Rewrite(f1);
            Temp_File := File_Name + '.OLD';
            If exist(Temp_File) then
                begin
                Assign(f2, Temp_file);
                Erase(f2);
                end;
            start:
              While not Eof(f) do
                  begin
                  readln(f, Line);
                  line_count:=line_count+1;
                  write(line_count:4);
                  if Line = '' then
                      goto start; ;
                  j := 0;
                  repeat
                      j := j + 1;
                  until line[j] <> ' ';
                  if line[j] = '*' then
                      goto start;
                  if (copy(line, j, 4) = 'TEXT') or (copy(line, j,
                     4) = 'text') then
                      begin
                      texton := true;
                      writeln(f1, 'TEXT');
                      goto start;
                      end;
                  if texton then
                      if (copy(line, j, 7) = 'ENDTEXT') or (copy(line, j,
                         7) = 'endtext') or (copy(line, j, 4) = 'ENDT') or
                         (copy(line, j, 4) = 'endt') then
                          begin
                          texton := false;
                          writeln(f1, 'ENDT');
                          goto start;
                          end
                      else
                          writeln(f1, line);

                  if not texton then
                      begin
                      NL := '';
                      checkit;
                      CommandLine;
                      writeln(f1, NL);
                      end;
                  end;
              write(f1, ^Z);
              Close(f1);
              close(f);
              ReName(f, File_Name + '.OLD');
              ReName(f1, File_Name + '.PRG');
              writeln;
              writeln;
              write(chr(7));
              writeln('Your original file is stored as ',File_Name,'.OLD');
              writeln('The compressed file is now ',File_Name,'.PRG');
              writeln;
              write('Press [RETURN] to continue...');
              read(kbd,ch);
            end;


        procedure help_dbfiles;
            begin
                ClrScr;
                writeln;
                writeln(
     'DBFILES.PAS  -   a  program to compress dBase II files and restore them'
                        );
                writeln(
     '                 back to a readable state. The program is a joining  of'
                        );
                writeln(
     '                 COMPDB.PAS and UNCOMPDB.PAS that I placed  on  several'
                        );
                writeln('                 R/CPM systems.');
                writeln;
                writeln('[E]xpand.');
                writeln;
                writeln(
    'This option will expand an  a  file  that has  been compressed  with the'
                        );
                writeln(
    '[C] option. Proper indentation will be made and all abbreviated commands'
                        );
                writeln(
    'will be  changed  to  their original  state  i.e.  APPE BLAN will become'
                        );
                writeln('APPEND BLANK.');
                writeln;
                writeln('[C]ompress.');
                writeln;
                writeln(
   'This option will compress a  dBase II command file. It eliminates spaces,'
                        );
                writeln(
    'comment lines and abbreviates dBase II commands to four characters. This'
                        );
                writeln(
    'give you a slight increase in  speed and  a considerable savings in disk'
                        );
                writeln('space.');
                writeln;
                writeln;
                writeln('Dave McCourt Williamsport Pa.');
                writeln;
                writeln('Press Return to continue...');
                read(ch);
            end;


        procedure Main_Page;
            begin
                ClrScr;
                gotoXY(15, 5);
                write('dBase file compander...by Dave McCourt');

                gotoXY(15, 10);
                write('Enter file name [max 8 char no file extent] ');
                gotoXY(15, 11);
                write('The .PRG will be added to the File name.');

                gotoXY(15, 15);
                write('[E]xpand [C]ompress [H]elp {Q}uit');
                read(kbd, ch);
                ch := UpCase(ch);
                if (ch = 'E') or (ch = 'C') then
                    begin
                    gotoXY(15, 13);
                    write('Your file name -->:');
                    read(File_Name);
                    if not exist(File_Name + '.PRG') then
                        begin
                        gotoXY(15, 15);
                        write('This file is not on this disk.        ');
                        write(chr(7));
                        delay(500);
                        write(chr(7));
                        delay(500);
                        ch := ' ';
                        end;
                    end;
            end;

        BEGIN
            ch := ' ';
            while ch <> 'Q' do
                begin
                Main_page;
                if ch = 'C' then
                    compress_files;
                if ch = 'E' then
                    expand_files;
                if ch = 'H' then
                    help_dbfiles;
                end;
        END.