program biglet ( fin, font, bigletp, fout, output );
  (* biglet: text enlargement program
     by Matthew Yarus
     module libraries required: delman, prgmods *)

label 1; (* used to halt program *)
const
(* begin module version *)
version = 1.69; (* of biglet.p 2003 Mar 27
2003 Mar 27, 1.69: give actual example.
1999 aug 5, 1.68: see font file.
1997 Dec 12: made page size large
1986 dec 15: previous changes
1982: origin *)
(* end module version *)

(* begin module describe.biglet *)
(*
name
   biglet: text enlargement program

synopsis
   biglet( fin: in, font: in, bigletp: in, fout: out, output: out )

files
   fin: contains user's text to be enlarged.
   font: the first line contains the actual height and width of characters
         in the font.  The following lines contain character images.  A
         character image has two parts, a reference character and the
         letter image.  Characters in the image that match the reference
         character are printed, while a mismatch prints a space.
   bigletp: contains parameters to control enlargement.  If the file is
         empty the fonts are not enlarged. otherwise, each line
         contains the height and width enlargement factors.  The line
         may also contain a character inside quote marks (single or
         double) to substitute for the matched characters of the font
         images.  Each line of bigletp corresponds to a fin text line.
         If there are no further lines, previously set values are used.
   fout: each line of fin is expanded by bigletp parameters and printed
         out in the form of the font images.
   output: messages to the user.

description
   Each letter of text (in file fin) is expanded and printed as a larger
   letter which is composed of many smaller letters.  The expansion can be
   set for each text line or for all lines with one parameter setting.
   There is an optional parameter which allows all the large letters of a
   specified line to be composed of a single character.  The larger letters
   are based on a file called font which can contain any sort of images.

examples
   For a font file whose first line is a left justified 5 4:
   f (sixth letter)     (a space)         - (a dash)
   fff-               ----                xxxx      Note: in the file each
   f---               ----                xxxx      character image must be
   fff-               ----                ---x      left justified and be
   f---               ----                xxxx      directly below the
   ----               ----                xxxx      previous image.
   Also, each image has mismatches at its right and below used for spacing.
   for bigletp:          example 1)   2 1         example 2)   3 2 'r'
                                                               1 2 'w'
   The first example magnifies the first and all subsequent text lines
   twice in height.  The second example magnifies the first line at 3 by 2
   and composes it out of 'r's.  The next line will be twice as wide as the
   font and composed of 'w's.  All subsequent fout text will be also be
   twice as wide but made up of the usual font characters.

   The phont file is a demonstration font file, while the font file
   is a working font.

   For this fin file:

biglet
is
fun!

   we get this fout file:

bbbbbbb   iiiiiiii   gggggg   ll        eeeeeeee  tttttttt
bb    bb     ii     gg    gg  ll        ee           tt
bb    bb     ii     gg        ll        ee           tt
bbbbbbb      ii     gg        ll        eeeeeee      tt
bb    bb     ii     gg        ll        ee           tt
bb    bb     ii     gg  gggg  ll        ee           tt
bb    bb     ii     gg    gg  ll        ee           tt
bb    bb     ii     gg    gg  ll        ee           tt
bbbbbbb   iiiiiiii   gggggg   llllllll  eeeeeeee     tt


iiiiiiii   ssssss
   ii     ss    ss
   ii     ss
   ii      ssssss
   ii           ss
   ii           ss
   ii           ss
   ii     ss    ss
iiiiiiii   ssssss


ffffffff  uu    uu  n     nn     !!
ff        uu    uu  nn    nn    !!!!
ff        uu    uu  nnn   nn    !!!!
fffffff   uu    uu  nnnn  nn    !!!!
ff        uu    uu  nn nn nn     !!
ff        uu    uu  nn  nnnn     !!
ff        uu    uu  nn   nnn
ff        uu    uu  nn    nn     !!
ff         uuuuuu   nn    nn     !!

see also
   {a set of fonts: } font

   {programs to remove blanks at the end of the line: }
   rembla.p rb.p

   {A script for automating the process is in the toolkit: }
   http://www.lecb.ncifcrf.gov/~toms/toolkit.html

author
   Matthew A. Yarus

bugs
   none known

technical notes
   If your font images are larger than program allows change constants
   letmaxhi and letmaxwi in biglet source code.
*)
(* end module describe.biglet *)

(* begin module biglet.constant *)

  (* more constants *)
  letmaxhi = 40; (* height limit of letter image, originally 20 *)
  letmaxwi = 40; (* width limit of letter image, originally 10 *)
  pagemaxhi = 2000; (* printout limit of standard paper height, originally 60 *)
  pagemaxwi = 2000; (* printout limit of standard paper width, originally 132 *)

(* end module biglet.constant *)

(* begin module biglet.type *)

type
  fontptr = ^fontrec; (* a pointer to fontrec *)
  fontrec = record (* each letter font is stored as a record *)
    letter: char; (* used as a reference point for letter images *)
    image: packed array [1..letmaxhi,1..letmaxwi] of boolean;
      (* this array holds the letter image. 'true' represents a match
         with the reference character, 'false' a mismatch *)
    next: fontptr; (* letter images are linked into a list *)
  end;
  loadtype = array[1..pagemaxwi] of fontptr; (* keeps fin text line
                                                characters in proper order *)

(* end module biglet.type *)

(* begin module biglet.var *)

var
  fin: text; (* user's text to be enlarged *)
  font: text; (* multiple letter images used for enlargement *)
  bigletp: text; (* enlargement and optional letter parameters *)
  fout: text; (* fin text after enlargement *)

(* end module biglet.var *)


(* 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 = 'prgmod 3.96  85 mar 18 tds'; *)


(* begin module biglet.fontload *)

procedure fontload ( var font: text; (* see global variables *)
                     var height: integer; (* innate height of letter image *)
                     var width: integer; (* innate width *)
                     var first: fontptr ); (* starting point of fontrec list *)

(* fontload converts font input file into linked list of font records *)

var
  counthi: integer; (* index of for loop 1 to height *)
  countwi: integer; (* index of for loop 1 to width *)
  letterhold: char; (* holds character for conversion into letter image
                       boolean value *)
  p: fontptr; (* used to build linked list of fontrec *)

begin (* fontload *)
  reset ( font );
  if eof ( font ) then begin (* check for fonts *)
    writeln ( output, ' font file is empty' );
    halt
  end; (* check for fonts *)

  readln ( font, height, width ); (* innate parameters *)
  if height > letmaxhi then begin
    writeln ( output, ' font images are too tall for biglet use. you' );
    writeln ( output, ' should change biglet source code constant letmaxhi.' );
    halt
  end;
  if width > letmaxwi then begin
    writeln ( output, ' font images are too wide for biglet use. you' );
    writeln ( output, ' should change biglet source code constant letmaxwi.');
    halt
  end;
  new ( first );
  p := first;
  while not eof ( font ) do begin
    readln ( font, p^.letter );
    for counthi := 1 to height do begin
      for countwi := 1 to width do begin
        if eoln ( font ) then begin
          writeln ( output, ' either font of "', p^.letter, '" or previous');
          writeln ( output, ' font has a line that is too short, is missing' );
          writeln ( output, ' a line, or is missing a matching letter above' );
          writeln ( output, ' the letter image. it is also possible that' );
          writeln ( output, ' height and width parameters at the top of the' );
          writeln ( output, ' font file are improperly set.' );
          halt
        end;
        read ( font, letterhold );
        if letterhold = ' '
        then begin
          writeln ( output, ' font character image of "', p^.letter,'"' );
          writeln ( output, ' contains a space which will cause' );
          writeln ( output, ' transportation errors.' );
          halt
        end;
        p^.image[counthi, countwi] := ( letterhold = p^.letter )
      end;
      readln ( font ) (* puts file cursor onto next line of font except in
                         final case where it goes to next font *)
    end;
    if eof ( font )
    then p^.next := nil (* marks end of list *)
    else begin
      new ( p^.next );
      p := p^.next
    end;
  end;
end; (* fontload *)

(* end module biglet.fontload *)

(* begin module biglet.double *)

procedure double ( first: fontptr ); (* marks start of fontrec list *)
(* halts biglet if there is more than one font for a given character *)
var
  pt: fontptr; (* points to fonts other than one being checked
                  for duplication *)
  pt2: fontptr; (* pointer to font that other fonts are
                   compared to *)
  double: boolean; (* 'true' when font is duplicated *)
  index: integer; (* counter for while loop *)
  index2: integer; (* counter for two small loops *)
  (* both index variables are used to number the two positions
     of the duplicate font records within the list *)

begin (* double *)
  index := 1;
  pt2 := first;
  pt := first;
  while not (( pt^.next = nil ) and ( pt2^.next = nil )) do begin
  (* nil marks end of font list *)
    index2 := 1;
    pt := first;
    repeat (* while loop above grabs font others are compared to,
              this loop grabs other fonts *)
      (* folowing while loop advances pt to one font past the one being
         checked because if any previous fonts were duplicated double
         would have already halted biglet *)
      while index2 < ( index + 1 ) do begin
        index2 := index2 + 1;
        pt := pt^.next
      end;
      double := ( pt^.letter = pt2^.letter ); (* the duplication check *)
      if double then begin
        writeln ( output, ' font number ', index:1, '(', pt2^.letter, ')' );
        writeln ( output, ' has a duplicate at font number ', index2:1 );
        halt
      end;
      index2 := index2 + 1;
      if pt^.next <> nil
      then pt := pt^.next;
    until ( pt^.next = nil);
    pt2 := pt2^.next; (* fonts others are compared to is advanced *)
    index := index + 1
  end;
end; (* double *)

(* end module biglet.double *)

(* begin module biglet.paraload *)

procedure paraload ( var bigletp: text; (* see global variables *)
                     var parahi: integer; (* user provided parameter of
                                             height expansion *)
                     var parawi: integer; (* width expansion *)
                     var linechar: char; (* holds bigletp optional character,
                                            see describe module,'examples' *)
                     var lctest: boolean ); (* 'true' indicates that optional
                                             character is to be used *)
(* paraload assigns expansion values to each line of text or the same
   values to every line and decides if each line is to be written using font
   characters or written with one optional character *)

var
  quotehold: char; (* holds first quote mark for comparison to second mark *)
  done: boolean; (* tests for completion of optional letter loop *)

begin (* paraload *)
  lctest := false;
  if not eof ( bigletp ) then begin (* if eof is 'true' than default or
                                       previous parameters are used *)
    read ( bigletp, parahi, parawi );
    if eoln ( bigletp )
    then readln ( bigletp ) (* no optional character used in current line *)
    else begin (* obtain optional character linechar *)
      done := false; (* loop initialization value *)
      repeat (* search for non-blank *)
        get ( bigletp );
        if eoln ( bigletp )
        then done := true (* no linechar given by user *)
        else begin
          if bigletp^ in ['''', '"'] (* holds initial quote *)
          then begin
            quotehold := bigletp^; (* pick up the first quote *)
            get ( bigletp );
            if eoln ( bigletp ) then begin
              writeln ( output, ' bigletp optional letter missing' );
              halt
            end;
            linechar := bigletp^;
            get ( bigletp );
            lctest := true; (* 'true' tells makebig procedure to use optional
                               character linechar in fout result *)
            done := true;
            if bigletp^ <> quotehold (* compares terminal quote to initial *)
            then begin
              writeln ( output,' bigletp letter ',linechar,' poorly quoted' );
              halt
            end;
          end
          else if bigletp^ <> ' ' then begin
            writeln ( output, ' quote marks required around bigletp' );
            writeln ( output, ' optional character' );
            halt
          end;
        end;
      until done;
      readln ( bigletp )
    end;
  end
end; (* paraload *)

(* end module biglet.paraload *)

(* begin module biglet.textcheck *)

procedure textcheck ( var bigletp: text; (* see global variables *)
                      var fin: text; (* global variable *)
                      height: integer; (* innate height of font image *)
                      width: integer ); (* innate width *)
(* textcheck verifies the presence of a fin file. then it decides if fin
   is too tall or too wide for page. *)

var
  countchar: integer; (* counts number of characters in each text line *)
  charhold: char; (* holds each character so that it may advance countchar*)
  parahi: integer; (* user provided parameter of height expansion *)
  parawi: integer; (* width parameter *)
  totalhi: integer; (* running total on projected height of output *)

begin (* textcheck *)
  reset ( fin );
  if eof ( fin ) then begin
    writeln ( output, ' no fin, no fout' );
    halt
  end;
  parahi := 1; (* default values *)
  parawi := 1;
  totalhi := 0; (* loop initialization value *)
  reset ( bigletp );
  repeat
    if not eof ( bigletp )
    then readln ( bigletp, parahi, parawi );
    if ( parahi <= 0 ) or ( parawi <= 0 ) then begin
      writeln ( output, ' expansion parameters of 0 or less' );
      writeln ( output, ' are not permitted' );
      halt
    end;
    countchar := 0; (* loop initialization value *)
    repeat
      countchar := countchar + 1;
      read ( fin, charhold )
    until eoln ( fin );
    readln ( fin ); (* 'until eoln' above does not do carriage return *)

    totalhi := totalhi + ( height*parahi );
    if totalhi > pagemaxhi then begin
      writeln ( output, ' text is too tall for page. you may want to' );
      writeln ( output, ' alter constant pagemaxhi(', pagemaxhi:1,' lines)');
      writeln ( output, ' in biglet source code.' );
      halt
    end;
    if parawi*countchar*width > pagemaxwi then begin
      writeln ( output, ' text is too wide for page. you may want to' );
      write ( output, ' alter constant pagemaxwi(', pagemaxwi:1 );
      writeln ( output, ' characters)' );
      writeln ( output, ' in biglet source code.' );
      halt
    end;
  until eof ( fin );
end; (* textcheck *)

(* end module biglet.textcheck *)

(* begin module biglet.charptr *)

procedure charptr ( charhold: char; (* holds character for conversion into
                                       pointer location *)
                    first: fontptr; (* beginning of linked list *)
                    var pt: fontptr ); (* points to font locations *)
(* charptr converts a character into a pointer representing the position
   of the character in the linked list of fontrec letter images *)

begin (* charptr *)
  pt := first;
  while ( pt^.next <> nil ) and ( pt^.letter <> charhold ) do
    pt := pt^.next;
  (* if pt^.letter never equals charhold then next section halts biglet *)
  if pt^.letter <> charhold then begin
    writeln ( output, ' font not found for character ''', charhold, '''' );
    halt
  end;
end; (* charptr *)

(* end module biglet.charptr *)

(* begin module biglet.lineload *)

procedure lineload ( var fin: text; (* see global variables *)
                     var textcount: integer; (* holds number of characters
                                                in each line as it is read *)
                     var loadl: loadtype; (* holds font locations of fin
                                             characters *)
                     first: fontptr ); (* marks beginning of list *)
(* lineload converts line of text into an array of integers so that makebig
   procedure can maintain the letter order of fin *)

var
  lethold: char; (* holds character for conversion into pointer by call of
                    procedure charptr *)

begin (* lineload *)
  textcount := 0; (* loop initialization value *)
  repeat
    textcount := textcount + 1;
    read ( fin, lethold );
    charptr ( lethold, first, loadl[textcount] );
    (* loadl is an array of pointers *)
  until eoln ( fin );
  readln ( fin ) (* 'eoln fin' does not go to next fin line *)
end; (* lineload *)

(* end module biglet.lineload *)

(* begin module biglet.makebig *)

procedure makebig ( var fout: text; (* see global variables *)
                    textcount: integer; (* passed from lineload, number
                                            of characters in each line *)
                    height: integer; (* innate height of letter image *)
                    width: integer; (* innate width *)
                    parahi: integer; (* user provided(in bigletp)
                                        height expansion parameter *)
                    parawi: integer; (* width parameter *)
                    linechar: char; (* holds bigletp optional character *)
                    lctest: boolean; (* 'true' indicates that linechar
                                        option is to be used *)
                    loadl: loadtype; (* holds fin line in proper order *)
                    first: fontptr ); (* points to beginning of fontrec
                                         list *)
 (* makebig enlarges fin and writes it in fout *)

var
  countph: integer; (* for loop index up to parahi *)
  countpw: integer; (* for loop index up to parawi *)
  countext: integer; (* for loop index up to textcount *)
  counthi: integer; (* for loop index up to height of letter image*)
  countwi: integer; (* for loop index up to width of letter image*)
  optionlet: char; (* holds either linechar or pt^.letter depending on which
                      one is to be used *)
  ch: char; (* holds actual character to be printed in fout *)
  pt: fontptr; (* points to font image for given fin character *)

begin (* makebig *)
  for counthi := 1 to height do (* next two loops ensure that fout lines
                                   divided by fin lines = hidth*parahi *)
    for countph := 1 to parahi do begin
      for countext := 1 to textcount do begin
        pt := loadl[countext];
        if lctest = false
        then optionlet := pt^.letter
        else optionlet := linechar;

        for countwi := 1 to width do begin (* this for loop and one below
                                              ensure that width of fout line
                                              is equal to width*parawi *)
          case pt^.image[counthi, countwi] of
            true: ch := optionlet;
            false: ch := ' '
          end;
          for countpw := 1 to parawi do
            write ( fout, ch )
        end;
      end;
      writeln ( fout )
    end;
end; (* makebig *)

(* end module biglet.makebig *)

(* begin module biglet.bletorder *)

procedure bletorder ( var fin: text; (* see global variables *)
                      var font: text; (* global variable *)
                      var bigletp: text; (* global variable *)
                      var fout: text ); (* global variable *)
(* structures biglet by ordering other procedures and aids reading of
   code by placing variable declarations next to where they are used *)

var
  height, width : integer; (* innate font and font list dimensions *)
  parahi, parawi: integer; (* user provided height and width parameters *)
  textcount: integer; (* holds number of characters in each line *)
  loadl: loadtype; (* holds pointer locations of fonts for fin characters *)
  linechar: char; (* holds optional parameter charracter *)
  lctest: boolean; (* 'true' indicates that linechar is to be used *)
  first: fontptr; (* points to beginning of the fontrec list *)

begin (* bletorder *)
  fontload ( font, height, width, first );
  double ( first );
  textcheck ( bigletp, fin, height, width );
  parahi := 1; (* default expansion parameters *)
  parawi := 1;
  rewrite ( fout );
  reset ( fin );
  reset ( bigletp );
  repeat
    paraload ( bigletp, parahi, parawi, linechar, lctest );
    lineload ( fin, textcount, loadl, first );
    makebig ( fout, textcount, height, width, parahi, parawi, linechar,
              lctest, loadl, first );
  until eof ( fin );
end; (* bletorder *)

(* end module biglet.bletorder *)


begin (* biglet *)
  writeln ( output, ' biglet ', version: 4: 2 );
  bletorder ( fin, font, bigletp, fout );
  writeln ( output, ' text has been enlarged' );
1: end. (* biglet *)