program split(sin,sout,splitp,output);
(* split: split a wide file into printable pages
      by thomas schneider
      copyright 1986

module libraries:  delman, prgmods, delmods
*)

label 1; (* end of the program *)

const
(* begin module version *)
version = 3.52; (* split 1986 nov 14
origin before 1982 june 25 *)
(* end module version *)

(* begin module describe.split *)
(*
name
      split: split a wide file into printable pages

synopsis
      split(sin: in, sout: out, splitp: in, output: out)

files
      sin: the file to be split into pages
      sout: the split result
      splitp: parameters to control split.  if splitp is empty,
         defaults are used.  otherwise splitp must contain 3 to 5 lines:
         1. if the first character is p (for 'page prompting') then the
            pagination is controlled by the sin.  (this is done by
            duplicating the first several columns to all the horizontal
            pages, as determined by the second parameter.)
            otherwise, pages begin as determined by the second parameter.
         2. for page prompting (see parameter 1) this is the number of
            columns to duplicate from the left margin to all pages.
            if not page prompting, then this is the lines per page in sin.
         3. columns per page in sin (not less than 1).
         4. number of header lines to copy to sout before splitting the rest.
         5. if 4. is negative, this is a trigger inside quotes (").
            -(4.) lines beyond this trigger splitting will begin.
         note: columns and lines per page refer to the input file, sin.
         to find the actual width of the output file pages, add 1 to
         parameter three (when not page prompting) or
         add parameter two to parameter three (when page prompting).
         one extra line is added per page for the page coordinate.
      output: messages to the user.

description
      the split program slices up the sin file into an array of pages,
      each located by an (x,y) coordinate.  in this way a file which is too
      large to print can be printed and then reconstructed.  in otherwords,
      if you have a program which produces output that is wider than the
      printer page (or the screen of the crt, for that matter) then you can
      run your output through split to obtain pages that will print ok.
      the upper lefthand corner of each page tells the coordinate of the page
      as (x down, y across).  a header page shows all the page coordinates.

examples
      if splitp contains: n/60/130/10 (on 4 lines) then sin will be
      split into 60 line by 130 column pages, after 10 header lines.
      if splitp contains: p/1/120/-5/"trigger" then each page will be 120
      characters wide and the first column will be copied to each page.
      the header extends 5 lines beyond and including the trigger.
      for p/5/132 the first 5 columns will be copied to each page.

author
      thomas d. schneider

bugs
      none known

technical notes
      constant pagecharacter is the (system dependent) begin page character.
*)
(* end module describe.split *)

(* technical notes:
the program copies the sin file into a linked list of internal files.
the program uses global variables in most cases *)

(* more constants: *)
      (* defaults for user settable variables *)
      defaultlinesperpage = 54;
      defaultcolumnsperpage = 80;
      defaultpageprompting = false;
      defaultheaderlines = 0;

      pagecharacter = ''; (* used to detect a new page if pageprompting *)

      quotemark = '"'; (* mark used around triggers *)

type
      pagebuffer = ^pbr;
      pbr = record (* page buffer record *)
         fi: text;
         next: pagebuffer
      end;

var
      sin: text; (* input to split *)
      sout: text; (* output of split *)
      splitp: text; (* yummy parameters *)

      linesperpage,
      columnsperpage: integer; (* page parameters *)

      maximumcolumns, (* sin file width *)
      pagecolumn: (* column of a page in sin *)
         integer;

      currentline: integer; (* line number on a page *)

      pages, (* page buffers linked list *)
      apage: (* one page buffer *)
         pagebuffer;

      pagex, pagey: integer; (* page coordinates *)

      pageprompting: boolean;
         (* false: pages are split by the program
            true: page size is determined by the first chardup columns
                  of sin which are duplicated to all pages *)
      chardup: integer; (* how many characters of each line to duplicate to
                           all pages *)

      headerlines: integer; (* the number of lines to copy to sout
         as a header.  if negative, a trigger phrase is used *)

(* begin module package.primitive *)
(* ************************************************************************ *)
(* begin module halt *)
procedure halt;
(* stop the program.  the procedure performs a goto to the end of the
   program.  you must have a label:
      label 1;
   declared, and also the end of the program must have this label:
      1: end.
   examples are in the module libraries.
   this is the only goto in the delila system. *)
begin
      writeln(output,' program halt.');
      goto 1
end;
(* end module halt version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module unlimitln *)
procedure unlimitln(var afile: text);
(* this procedure removes a stupid system dependent limit on the number of
lines that one can write to a file.  you may remove it from the code if
your system does not want or need this.  suggested method: place comments
around the contents of the procedure. *)
begin
      linelimit(afile, maxint); (* set 'infinite' lines allowed for afile *)
end;
(* end module unlimitln version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module copyaline *)
procedure copyaline(var fin, fout: text);
(* copy a line from file fin to file fout *)
begin (* copyaline *)
      while not eoln(fin) do begin
         fout^ := fin^;
         put(fout);
         get(fin)
      end;
      readln(fin);
      writeln(fout);
end; (* copyaline *)
(* end module copyaline version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module copylines *)
function copylines(var fin, fout: text; n: integer): integer;
(* copy n lines of file fin to file fout.
the actual number of lines copied is returned. *)
var
      index: integer; (* the current line number *)
begin (* copylines *)
      index := 0;
      while (not eof(fin)) and (index < n) do begin
         copyaline(fin, fout);
         index := succ(index)
      end;

      copylines := index
end; (* copylines *)
(* end module copylines version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* ************************************************************************ *)
(* end module package.primitive version = 'delmod 6.51 85 apr 17 tds/gds' *)

procedure initialize;
(* initialize sout *)
begin (* initialize *)
      writeln(output,' split ',version:4:2);
      unlimitln(sout);
      rewrite(sout);
      writeln(sout,' split ',version:4:2);
end; (* initialize *)

procedure readpageparameters;
(* read page parameters from splitp *)
begin (* readpageparameters *)
      reset(splitp);

      if eof(splitp)
      then begin
         pageprompting := defaultpageprompting;
         linesperpage:=defaultlinesperpage;
         columnsperpage:=defaultcolumnsperpage;
         headerlines := defaultheaderlines
      end
      else begin (* read in the parameters *)
         if splitp^='p'
            then pageprompting := true
            else pageprompting := false;
         readln(splitp);

         if eof(splitp) then begin
            writeln(output,' missing second parameter.');
            halt
         end;
         readln(splitp,linesperpage);

         if eof(splitp) then begin
            writeln(output,' missing third parameter.');
            halt
         end;
         readln(splitp,columnsperpage);

         if not eof(splitp) then readln(splitp, headerlines)
                            else headerlines := defaultheaderlines
      end;

      if columnsperpage < 1 then begin
         writeln(output,' columns per page must be >= 1.');
         halt
      end;


      writeln(sout);
      if pageprompting
      then begin
         chardup := linesperpage;
         if chardup < 0 then chardup := 0; (* force it to be at least zero *)
         writeln(sout,' pages prompted from input.');
         writeln(sout,' ',chardup:1,
                         ' character(s) duplicated on each line.')
      end
      else begin
         chardup := 0;
         writeln(sout,' not prompting pages from input.');
         writeln(sout,' ',linesperpage:1,' lines per page')
      end;
      writeln(sout,' ',columnsperpage:1,' columns per page');
      writeln(sout,' ',headerlines:1,' fourth parameter',
                   ' (requested header lines)');
end; (* readpageparameters *)

procedure findwidthheader(var afile, headerp, report: text;
                          var maximumcolumns, headerlines: integer);
(* find the width and number of header lines of a file.
if headerlines is negative, then a triggerphrase is used from headerp
to find headerlines and the phrase is reported to file report *)
const
      maxstring = 50; (* the largest trigger allowed *)

type
(* begin module interact.type *)
      string = record (* a string of characters *)
         letters: array[1..maxstring] of char; (* the letters in the string *)
         length: integer; (* the number of characters in the string *)
         current: integer; (* the letter we are working on *)
      end;
(* end module interact.type version = 'prgmod 3.96  85 mar 18 tds'; *)

(* begin module trigger.type *)
      trigger = record (* an object to be searched for *)
         seek: string; (* the characters looked for *)
         state: integer; (* how close to triggering we are *)
         skip: boolean; (* trigger not found- skip the line *)
         found: boolean (* the trigger was found *)
      end;
(* end module trigger.type version = 'prgmod 3.96  85 mar 18 tds'; *)
var
      currentcolumn: integer; (* current position in afile *)
      linenumber: integer; (* the current line in afile *)
      headertrigger: trigger; (* the trigger phrase used when headerline
         is negative... to determine a positive value for headerline *)
      skip: integer; (* for skipping lines just below header trigger *)
(* begin module trigger.proc *)
(* this module allows one to scan a series of characters, as from
an array or a file, and to "trigger" or detect a simple string
in the series.  the advantage of the trigger is that several triggers
can "observe" a stream of characters at once, each looking for a
different thing.
some other modules required: interact.const, interact.type *)

procedure resettrigger(var t: trigger);
(* reset the trigger to ground state *)
begin (* resettrigger *)
      with t do begin
         state := 0;
         skip := false;
         found := false
      end
end; (* resettrigger *)

procedure testfortrigger(ch: char; var t: trigger);
(* look at the character ch.
   if it is part of the trigger (at the current trigger state),
       then the trigger state goes higher.
   if it is not part of the trigger then the trigger state is reset,
      skip is true and one should skip onward to find the trigger.
   if the trigger is found, found is true. *)
begin (* testfortrigger *)
      with t do begin
         state := succ(state);
(*         if debugging then begin
            writestring(list,seek);
            writeln(list,'testfortrigger seek.letters[',state:1,']:',
                           seek.letters[state],' ch:',ch);
         end;*)
         if seek.letters[state] = ch
         then begin
            skip := false;
            if state = seek.length then found := true
                                   else found := false
         end
         else begin (* reset trigger *)
            state := 0;
            skip := true;
            found := false
         end
      end
end; (* testfortrigger *)
(* end module trigger.proc version = 'prgmod 3.96  85 mar 18 tds'; *)
begin (* findwidthheader *)

      if headerlines < 0 then begin (* obtain trigger phrase *)
         write(report,' trigger phrase: ');
         (* find start quote *)
         while headerp^ <> quotemark do begin
            if eof(headerp) then begin
               writeln(output,' trigger phrase not found in quotes (',
                  quotemark,')');
               halt
            end;
            if eoln(headerp) then begin
               writeln(output,' trigger phrase missing');
               halt
            end;
            get(headerp)
         end;
         write(report,headerp^); (* the quotemark found *)
         get(headerp); (* move past the quotemark *)

         resettrigger(headertrigger);
         with headertrigger.seek do begin (* fill er up *)
            length := 0;
            while headerp^ <> quotemark do begin
               if eof(headerp) or eoln(headerp) then begin
                  writeln(output,' end of trigger not found');
                  halt
               end;

               length := succ(length);
               if length > maxstring then begin
                  writeln(output,' trigger exceeds ',maxstring:1,
                     ' characters');
                  halt
               end;
               letters[length] := headerp^;
               write(report,headerp^);
               get(headerp)
            end;
            write(report,headerp^); (* final quote mark *)
            writeln(report)
         end
      end;

      (* scan afile to find maximum width and also find trigger *)
      reset(afile);
      maximumcolumns:=0;
      linenumber := 1;
      while not eof(afile) do begin
         currentcolumn:=0;
         while not eoln(afile) do begin
            if headerlines < 0 then begin
               testfortrigger(afile^,headertrigger);
               if headertrigger.found then begin
                  (* skip beyond header *)
                  for skip := 1 to -headerlines do begin
                     if eof(afile) then begin
                        writeln(output,' the entire file was a header');
                        halt
                     end;
                     readln(afile); (* ignore this line *)
                     linenumber := succ(linenumber)
                  end;
                  maximumcolumns := 0; (* reset since header is not split *)
                  currentcolumn := 0;

                  (* now make headerlines the actual positive number: *)
                  headerlines := linenumber - 1; (* the previous line *)
               end;
            end;
            currentcolumn:=succ(currentcolumn);
            get(afile)
         end;
         readln(afile);
         linenumber := succ(linenumber);
         if currentcolumn > maximumcolumns then maximumcolumns:=currentcolumn
      end;

      if headerlines < 0 then begin
         writeln(output,' trigger phrase not found in sin');
         halt
      end;

      writeln(report);
      writeln(report,' actual number of header lines: ',headerlines:1);
      writeln(report);
      writeln(report,' input file width: ', maximumcolumns:1,' characters');

end; (* findwidthheader *)

procedure allocatepagebuffers;
(* allocate page buffers *)
var
      currentcolumn: integer; (* current position *)
      totalpagesacross: integer; (* total pages across *)
begin (* allocatepagebuffers *)
      currentcolumn:=0;
      pagecolumn:=0;
      new(apage);
      pages:=apage;
      totalpagesacross := 1; (* pointed to by pages *)

      while currentcolumn < maximumcolumns do begin
         if pagecolumn = columnsperpage then begin
            new(apage^.next);
            totalpagesacross := succ(totalpagesacross);
            apage:=apage^.next;
            pagecolumn:=0
         end;
         currentcolumn:=succ(currentcolumn);
         pagecolumn:=succ(pagecolumn)
      end;
      apage^.next:=nil;

      writeln(sout);
      writeln(sout,' total pages across: ', totalpagesacross:1);
      writeln(sout);
end; (* allocatepagebuffers *)

procedure coordinate(var afile: text);
(* write the global page coordinate into a file *)
begin
      write(afile,' (',pagex:3,',',pagey:3,')')
end;


procedure newpage;
(* make a new page in each page of the linked list whose
root is pages.  also, write the coordinates to sout. *)
begin (* newpage *)
      write(sout, ' ');
      pagex := succ(pagex);
      pagey := -1;
      apage := pages;
      currentline := 0;

      while apage <> nil do begin
         pagey := succ(pagey);
         write(apage^.fi, pagecharacter);
         coordinate(apage^.fi);
         coordinate(sout);
         writeln(apage^.fi);
         apage := apage^.next
      end;
      writeln(sout)
end; (* newpage *)

procedure breaksinintobuffers;
(* break sin into buffers *)
var
      skip: integer; (* for skipping the header *)
      duplicated: integer; (* number of characters duplicated to each
                             page buffer so far, when pageprompting *)
begin (* breaksinintobuffers *)
      (* move to top of sin and skip header *)
      reset(sin);
      for skip := 1 to headerlines do readln(sin);
      pagecolumn:=0; (* we are on column zero *)

      (* rewrite buffers *)
      apage:=pages;
      while apage<>nil do begin
         rewrite(apage^.fi);
         apage:=apage^.next
      end;
      pagex:=-1;

      (* force a move to the first page if needed *)
      if pageprompting
      then begin
         if sin^ <> pagecharacter then newpage
      end
      else newpage;

      (* write lines of sin into buffers *)
      while not eof(sin) do begin
         if pageprompting then begin
            duplicated := 0;
            (* move to next page, if needed *)
            if sin^ = pagecharacter then begin
               newpage;
               get(sin); (* move past the page symbol *)
               apage := pages;
               while apage <> nil do begin
                  write(apage^.fi,' '); (* substitute blank for page symbol*)
                  apage := apage^.next
               end;
               duplicated := succ(duplicated)
            end;

            (* duplicate chardup characters to each page *)
            while (duplicated < chardup) and not eoln(sin) do begin
               apage := pages;
               while apage <> nil do begin
                  if not eoln(sin) then write(apage^.fi,sin^);
                  apage := apage^.next
               end;
               get(sin);
               duplicated := succ(duplicated)
               (* note: these pagecolumns are not counted *)
            end
         end
         else begin (* not page prompting *)
            (* move to next page, if needed *)
            if currentline >= linesperpage then newpage;


            (* put blank in first column of each buffer *)
            apage:=pages;
            while apage <> nil do begin
               write(apage^.fi,' ');
               apage:=apage^.next
            end
            (* note: these pagecolumns are not counted *)
         end;

         (* copy the rest of the line out to the file buffers *)
         apage:=pages;
         while not eoln(sin) do begin
            if pagecolumn = columnsperpage
            then begin
               apage:=apage^.next;
               pagecolumn:=0
            end;
            pagecolumn:=succ(pagecolumn);
            write(apage^.fi,sin^);
            get(sin)
         end;

         (* writeln all buffers *)
         apage:=pages;
         while apage <> nil do begin
            writeln(apage^.fi);
            apage:=apage^.next
         end;

         readln(sin);
         pagecolumn:=0; (* we are back on column zero *)
         currentline:=succ(currentline)
      end
end; (* breaksinintobuffers *)

procedure copybufferstosout;
(* copy buffers to sout *)
begin (* copybufferstosout *)
      apage:=pages;
      while apage <> nil do begin
         reset(apage^.fi); (* reset all buffers *)
         while not eof(apage^.fi) do begin
            if not eoln(apage^.fi) then write(sout,apage^.fi^);
            while not eoln(apage^.fi) do begin
               get(apage^.fi);
               write(sout,apage^.fi^)
            end;
            readln(apage^.fi);
            writeln(sout)
         end;
         apage:=apage^.next
      end
end; (* copybufferstosout *)

begin (* split *)
      initialize;
      readpageparameters;
      findwidthheader(sin, splitp, sout, maximumcolumns, headerlines);

      allocatepagebuffers;

      breaksinintobuffers;

      reset(sin);
      if headerlines <> 0 then page(sout);
      headerlines := copylines(sin, sout, headerlines);

      copybufferstosout;
1: end. (* split *)