ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/PROGRAMS/WSTAR/WS-COL12.LBR/WS-COL12.PQS/WS-COL12.PAS

Pascal/Delphi Source File | 2000-06-30 | 15KB | 468 lines

PROGRAM WSCOLUM; (* WS-COLUM 1.2 *)

(* Released into the public domain January 1986
   by the author:

                    Steve Wilcox
                 1215 South Osceola
                  Denver, CO 80219
                    303-936-0440

   I would appreciate being notified of any
   problems or changes in the program.

     This program will take a WordStar text file
  of two pages or more and arrange consecutive
  pages in sets of columns. The program keeps track
  of WordStar print control toggles to keep them
  associated with only the text block in which they
  were begun.
     The three user-input variables are the name
  of the source file, the name of the destination
  file, and the print column numbers that will be
  the left margin for subsequent text blocks.
     In the ReadNWrite Procedure, the source file
  is read into memory a set of pages at a time
  (depending on how many columns have been entered),
  using a double-tiered linked list. Each page break
  is pointed to with a PagePointer, which in turn
  points to the beginning of the second linked
  list (BufferStorage), the actual text in that
  page.
     The text is stored in a series of consecutive
  arbitrary 128 byte records (BufferStorage)
  rather than line-by-line records. This eliminates
  the need to pre-guess the length of any line
  coming in from the input file.
     With a set of pages in memory, they are read
  back out by following the BufferStorage linked
  lists for the page sets until WordStar's page-end
  character (#138) is encountered.
     The set of pages is assembled side-by-side
  to the final file by outputting corrresponding
  lines from each page in the set, with spaces
  between them for the center margins. After the
  output page is done, ReadNWrite goes through
  another iteration.
     Screen prompts in this program are set for a
  52 column screen.                    *)

(* 6/26/86  Changed the ReadNWrite Procedure to
            accommodate files that don't end in a
            carriage return. The program now
            appends a CR/PageBreak sequence at the
            end of the file if it doesn't have one.
            The buffer code in ReadASet was moved
            to the new Store procedure to
            accommodate storing characters from
            different code locations.

   8/21/86  The above modification, it turns out,
            also corrects a problem when a new
            LineStore record is created exactly when
            the PageBreak character is encountered.
            The effect was that the following page
            of the source file was read into memory,
            but never read out; it was discarded.
              However it brought to light a similar,
            though undoubtedly rare problem when a
            new LineStore record is created exactly
            at EOF. The problem was corrected by
            filling the LineStore position after
            the new record has been created.
            Originally, the need for a record was
            determined, and the record itself
            created, after storage.
              Made a minor modification to the
            MergePages procedure to prevent excess
            space characters from being added if
            a full implement of columns is not
            present on the last page.
              Added provision in  ControlCheck to
            adjust LineCharCount for certain
            sub-printable ASCII characters that are
            printable in WordStar. Originally no
            character below ASCII 31 would be
            counted as a printing character, thus
            the column justification would be
            wrong if special characters were
            used.
              Modified the routine to read initial
            dot commands. They are now written
            directly to the outputfile, rather
            than stored. This accommodates much
            larger headers.
              Modified AbortProgram to close and
            erase the output file rather than
            leave it partially written. *)


{$I-}
CONST
  LF=#10;                         (* LineFeed Character *)
  CR=#13;                         (* Carriage Return Character *)
  PageBreak=#138;                 (* WordStar's PageBreak Character *)

TYPE
  StoragePointer=^BufferStorage;  (* The text of each page is  *)
  BufferStorage=Record            (* stored in LineStore       *)
    LineStore:String[128];
    StorageLink:StoragePointer
  End;

  PagePointer=^PageInfo;          (* Points to the beginning   *)
  PageInfo=Record                 (* BufferStorage for each    *)
    Start:StoragePointer;         (* text page                 *)
    PageLink:PagePointer
  End;

  WriteString=Char;            (* used for WriteDisk procedure *)

VAR
  I,BuffCounter,PageCounter,Blocks:Byte;
  Z:Integer;
  Ch:Char;
  InputFileName,OutputFileName:String[14];
  InputFile,OutputFile:Text;
  TempString:String[255];
  BuffPrevious,BuffNext:StoragePointer;
  PageHead,PagePrevious,PageNext:PagePointer;
  HeapTop:^Integer;
  InitialPass:Boolean;
  Column:Array[1..20] of Integer;

  PROCEDURE AbortProgram (Code:Byte);
  (* Dumps out of program due to fatal condition *)
  CONST
    AbortMessage:Array[1..3] of String[21]=
      ('Source File not found',
       'Destination disk full',
       ' Page blocks overlap ');
  Begin
    GotoXY(1,22);ClrEOL;
    WriteLn(#7,'>> Program Aborted <<');
    WriteLn(AbortMessage[Code]);
    Close(OutputFile);
    Erase(OutputFile);
    Halt
  End;


  PROCEDURE WriteDisk (InString:WriteString);
  (* Writes to OutputFile and checks for disk write error *)
  Begin
    Write(OutputFile,InString);
    If IOResult>0 then AbortProgram(2)  (* Fatal Error -- no return *)
  End;


  PROCEDURE Configuration;
  (* Gets input information from user *)

    PROCEDURE DrawLine (Row:Byte);
    (* Draws a dashed line across the screen at the specified ROW *)
    Begin
      GotoXY(1,Row);
      For I:=1 to 52 do Write('-')
    End;

  Begin (* Configuration *)
    Repeat
      ClrScr;

      GotoXY(17,1);
      Write('C O L U M N S  1.2');
      DrawLine(3);
      DrawLine(20);

      GotoXY(1,5);
      WriteLn('Enter the name of the SOURCE file');
      ReadLn(InputFileName);

      GotoXY(1,9);
      WriteLn('Enter the name of the DESTINATION file');
      ReadLn(OutputFileName);

      GotoXY(1,13);
      WriteLn('The program begins the first text block in column 1.');
      WriteLn('Enter the STARTING COLUMN(S) for subsequent block(s),');
      WriteLn('each separated by a space');
      ReadLn(TempString);

      (* Now parse the line for each column number *)
      Blocks:=1;
      While Length(TempString)>0 do
      Begin
        While (Length(TempString)>0) and not (TempString[1] in ['0'..'9']) do
          Delete(TempString,1,1);
        I:=1;
        If Length(TempString)>0 then
        Begin
          While (I<=Length(TempString)) and (TempString[I] in ['0'..'9']) do
            I:=Succ(I);
          Val(Copy(TempString,1,I-1),Column[Blocks],Z);
          Blocks:=Succ(Blocks);
          Delete(TempString,1,I);
        End;
      End;
      WriteLn;
      Write(Blocks,' Blocks, beginning at Columns: 1');
      For I:=1 to Blocks-1 do Write(Column[I]:4);


      (* Now subtract 2 from each Column since
         Column actually controls the number of
         SPACES inserted between the end of one
         block and the beginning of the next *)
      For I:=1 to Blocks do
        Column[I]:=Column[I]-2;

      GotoXY(1,22);
      Write('Are all entries correct? (Y/N) ');
      Repeat
        Read(Kbd,Ch);
      Until UpCase(Ch) in ['Y','N'];
    Until UpCase(Ch)='Y';

    Assign(InputFile,InputFileName);
    Assign(OutputFile,OutputFileName)
  End;


  PROCEDURE InitializeFile;
  (* Opens files and reads in any leading dot
     commands *)
  Begin
    GotoXY(1,22);ClrEOL;
    Write('Processing...');

    InitialPass:=True;
    Reset(InputFile);
    If IOResult>0 then AbortProgram(1); (* Fatal error -- no return *)
    ReWrite(OutputFile);
    If IOResult>0 then AbortProgram(2); (* Fatal Error -- no return *)

    Read(InputFile,Ch);
    While Ch ='.' do
    Begin
      (* Looks for dot commands. Any such
         formatting commands are written directly to the output. *)
      ReadLn(InputFile,TempString);
      WriteLn(OutputFile,Ch,TempString);
      Read(InputFile,Ch);
    End;
    (* Note that Ch is now first character of the text *)
  End;

  PROCEDURE ReadNWrite;
  (* Reads in a set of pages and puts them side-by-side in proper columns *)

  VAR
    BlockLoop:Byte;
    BuffPosCount:Array[1..20] of Byte;
    PageLine:Array[1..20] of StoragePointer;
    PageDone,RealPage,UnderScore,BoldFace,DoubleStrike:Array [1..20] of Boolean;
    AllPagesDone:Boolean;

    PROCEDURE ReadASet;
    (* Reads a set of pages from the source file *)

      PROCEDURE Store (InChar:Char);
      (* stores character in memory and allocates records *)
      Begin
        BuffCounter:=Succ(BuffCounter);
        If BuffCounter>128 then  (* Create new record in memory *)
        Begin
          BuffPrevious:=BuffNext;
          New(BuffNext);
          BuffPrevious^.StorageLink:=BuffNext;
          BuffCounter:=1
        End;
        BuffNext^.LineStore[BuffCounter]:=InChar;
      End;

    Begin (* ReadASet *)
      New(PageHead);
      PageNext:=PageHead;
      PageCounter:=0;
      While (PageCounter<Blocks) and (Not EOF(InputFile)) do
      Begin
        PageCounter:=Succ(PageCounter);
        New(BuffNext);                           (* Set up pointers to next *)
        PagePrevious:=PageNext;                  (* page and initial storage*)
        New(PageNext);                           (* location for each page  *)
        PagePrevious^.PageLink:=PageNext;
        PageNext^.Start:=BuffNext;
        BuffCounter:=0;

        If InitialPass then  (* Store Ch left over from above Dot Search *)
        Begin
          Store(Ch);
          InitialPass:=False
        End;

        Repeat
          Read(InputFile,Ch);
          Store(Ch);
        Until (EOF(InputFile)) or (Ch=PageBreak);

        If (Ch<>LF) and (Ch <> PageBreak) then (* EOF needs CR/PageBreak *)
        Begin
          Store(CR);
          Store(PageBreak)
        End
        Else (* make sure last buffer character is PageBreak *)
          BuffNext^.LineStore[BuffCounter]:=PageBreak
      End
    End;


    PROCEDURE QueuePages;
    (* Points to the beginning of the each page *)
    Begin
      PageNext:=PageHead^.PageLink;
      For I:=1 to Blocks do
      Begin
        PageDone[I]:=(I>PageCounter);     (* In case the last page has no pair *)
        If not PageDone[I] then
        Begin
          PageLine[I]:=PageNext^.Start;
          PageNext:=PageNext^.PageLink
        End
      End
    End;


    PROCEDURE MergePages;
    (* Assembles output page from the pages in memory *)
    VAR
      LineCharCount:Byte;

      FUNCTION SevenBit(InChar:Char):Char;
      (* Strips high-bit off WordStar formatting *)
      Begin
        SevenBit:=Chr(Ord(InChar) And 127)
      End;

      FUNCTION BuffChar(Block:Byte):Char;
      (* Retrieves text character from page *)
      Begin
        BuffChar:=PageLine[Block]^.LineStore[BuffPosCount[Block]];
        BuffPosCount[Block]:=Succ(BuffPosCount[Block]);
        If BuffPosCount[Block]>128 then  (* get next BufferStorage *)
        Begin
          PageLine[Block]:=PageLine[Block]^.StorageLink;
          BuffPosCount[Block]:=1
        End
      End;

      PROCEDURE ControlCheck (Block:Byte);
      (* Toggles WordStar Print Controls *)
      Begin
        Case SevenBit(Ch) of
          #19:UnderScore[Block]:=not UnderScore[Block];
          #02:BoldFace[Block]:=not BoldFace[Block];
          #04:DoubleStrike[Block]:=not DoubleStrike[Block]
        End;

        If SevenBit(Ch) in [#06,#07,#15] then
          (* printables: Phantom space, phantom rubout, non-break space *)
          LineCharCount:=Succ(LineCharCount);
        If SevenBit(Ch)=#08 then
          (* Backspace, so decrement *)
          LineCharCount:=Pred(LineCharCount)
      End;

      PROCEDURE SetControls (Block:Byte);
      (* Inserts WordStar print controls at the beginning and end of lines *)
      Begin
        If UnderScore[Block] then WriteDisk(#19);
        If BoldFace[Block] then WriteDisk(#2);
        If DoubleStrike[Block] then WriteDisk(#4)
      End;



    Begin (* MergePages *)
      For I:=1 to PageCounter do
        BuffPosCount[I]:=1;
      Repeat
        LineCharCount:=0;
        For BlockLoop:=1 to Blocks do
        Begin
          SetControls(BlockLoop);

          If PageDone[BlockLoop] then (* No text so make blank line *)
          Begin
            If BlockLoop=Blocks then (* end line with CR *)
              WriteDisk(CR)
          End
          Else  (* print the text line *)
          Begin
            Repeat
              Ch:=BuffChar(BlockLoop);
              If SevenBit(Ch)<#31 then  (* might be a control toggle *)
                ControlCheck(BlockLoop)
              Else
                LineCharCount:=Succ(LineCharCount); (* increases for ASCII only *)
              If SevenBit(Ch)<>CR then WriteDisk(Ch);
            Until SevenBit(Ch)=CR;    (* end of the line *)
            SetControls(BlockLoop);

            If (BlockLoop<Blocks) and
               (LineCharCount>Succ(Column[BlockLoop]))
            then
              AbortProgram(3);    (* Fatal Error -- no return *)

            If BlockLoop<Blocks then
              Begin
                For I:=LineCharCount to Column[BlockLoop] do
                  WriteDisk(' ');     (* Print spaces over to start of next page *)
                LineCharCount:=Column[BlockLoop]+1
              End
            Else
              WriteDisk(CR);
            Ch:=BuffChar(BlockLoop);  (* Checks for End of Page marker *)
            PageDone[BlockLoop]:=(Ch=PageBreak)  (* No more on that page *)
          End
        End;
        AllPagesDone:=True;
        For I:=1 to Blocks do
          AllPagesDone:=(AllPagesDone and PageDone[I]);
        If AllPagesDone then
          WriteDisk(PageBreak)   (* finish return page marker *)
        Else
          WriteDisk(LF);   (* finish return with normal return *)
      Until AllPagesDone
    End;



  Begin (* ReadNWrite *)
    For I:=1 to Blocks do
    Begin
      UnderScore[I]:=False;
      BoldFace[I]:=False;
      DoubleStrike[I]:=False;
    End;
    Mark(HeapTop);
    While not EOF(InputFile) do
    Begin
      ReadASet;
      For I:=1 to Blocks do
        PageDone[I]:=False;
      QueuePages;   (* Point to Page beginnings *)
      MergePages;   (* Pages are in queue, now put them together *)
      Release(HeapTop)
    End;
    Close(OutputFile);
    GotoXY(1,22);
    WriteLn('The finished file is on <',OutputFileName,'>.')
  End;


Begin (* WS-COLUM *)
  Configuration;
  InitializeFile;
  ReadNWrite
End.