program alist(inst, book, alistp, colors,
              namebook, namelist, avalues,
              list, clist, output);

(* aligned listing of a book.

  Thomas D. Schneider, Ph.D.
  toms@alum.mit.edu
  https://alum.mit.edu/www/toms 

      module libraries: delman, delmods, prgmods *)

label 1; (* end of program *)

const
(* begin module version *)
   version = 6.64; (* of alist.p 2017 Jan 02
2017 Jan 02: 6.64: variable value -> cvalue
2015 Jun 24: 6.63: clean up
2015 Jun 24: 6.62: handle negative coordinates?  Longer names???
                   getpositions now handles negative coordinates properly
                   with abmin and abmax replacing variable ab.
2013 Jan 17: 6.61: increase maximumrange in delmod
2012 Mar 31: 6.60: ability to remove number column
2011 May 11: 6.59: bug: namelist only uses first name - emptyfile is resetting!
                   solution: use emptyfile ONLY ONCE and record result in boolean
2007 Nov 29: 6.58: ury of bounding box huge when multiple pages;
                   fix page line ogic
2007 Jun 22: 6.57: 'The piece name in the book' - allow dotted names
2005 Sep 21: 6.56: emptyfile should reset the file so reads are ok!
2005 Sep 19: 6.55: cleanup
2005 Sep 19: 6.54: REALLY set the boundary at 2 characters in emptyfile.
2005 Sep 15: 6.53: set the boundary at 2 characters in emptyfile.
2005 Sep 15: 6.52: namewidth problem ... I kludged it for now.
                   the namebook and namelist files normally would have
                   at least 5 characters.  So this was used as the
                   test for 'empty'.  See the emptyfile routine.  The
                   emptyfile routine replaces eof() in several places.
2005 Sep 13: 6.51: fix namewidth so it works with gpc!
                   ... no must use new compiler.
2005 Sep 13: 6.50: delmod module upgrade
2005 Jan 27: 6.49: Abandon changes in 47 and 46, keep f function.
                   It seems impossible to detect an empty file
                   using the GPC compiler!
                   THIS PROGRAM MUST BE COMILED WITH p2c (tc script)!!!
2005 Jan 27: 6.47: BUG: emptyfile routine to detect empty files.
2005 Jan 27: 6.46: BUG: In GPC, an empty file is not at eof when
                   reset.  How nice!  So the namelistwidth failed.  
2005 Jan 27: 6.45: postscript f function for setting fonts.
2004 Sep  8: 6.44: clean for GPC
2004 Aug 30: 6.43: maximum range set to 1001
2004 Jul 17: 6.42: delila mutation names not shown correctly
2004 Jul 11: 6.41: only display orientation if piece is given
2004 Jul  8: 6.40: upgrad to prgmod, isblank to work on all compilers
2004 Jul  7: 6.39: bug in reading bounding boxes
2004 Jun  7: 6.38: bounding box must be integers, not real
2002 Sep  5: 6.37: remove debugging residue, upgrade page boundaries
2002 Sep  5: 6.36: clean documentation
2002 Apr 19: 6.35: introduce line number control
2002 Jan 13: 6.34: upgrade documentation; mention version parameter line!
2001 Nov  5: 6.33: paging is NOT done to clist at all times!
2001 Aug 29: 6.32: edgecontrol variables written to clist are in cm
2001 Mar 26: 6.31: allow coordinate without piece name
2001 Mar 26: 6.30: check for 'program list header problem' neutralized.
2000 Nov 16: 6.28: fix reading of name instruction in delmod
2000 Nov 16: 6.27: gpc compatable!
2000 Oct 16: 6.26: increment maximumrange
2000 Jul 13: 6.25: tech notes about autoupgrade
2000 Jun 28: 6.24: headercontrol: 0 = no numbar
2000 Jun 24: 6.23: expand range to +/-1000
2000 Jun 24: 6.19: allow user to remove header by a parameter
2000 Jun 24: 6.12: precompute number oflines to make ghostview display tight.
2000 Jun 21: 6.07: full position of display controls installed, finally!
2000 Jun 21: 5.96: old parameter files are now automatically upgraded!
2000 Jun 20: 5.93: pnumberbar modified to use numberbar so it auto-upgrades!
2000 Jun 20: 5.90: introducing edgecontrol from makelogo
2000 May 10: 5.80: getname and printname now use getocp - very clean!!!
1999 Jul 24: 5.79: numberwidth is computed only in numbersize
1999 May 18: set bounding box for for the Canon Color Laser Copier 800S
1998 Oct 19: range set to 1000
origin before 1982 June 22 *)
updateversion = 6.20; (* defines lowest acceptable current parameter file *)
(* end module version *)

(* begin module describe.alist *)
(*
name
      alist: aligned listing of a book

synopsis
      alist(inst: in, book: in, alistp: inout, colors: in,
            namebook: in, namelist: in, avalues: in,
            list: out, clist: out, output: out)

files
      inst: delila instructions of the form 'get from 56 -5 to 56 +10;'
         If this file is empty, then the sequences will be
         aligned either by their 5' ends or by their zero base,
         depending on the 4th parameter in alistp.

      book: the book generated by delila using inst

      alistp: parameters to control the program.  If empty, the range of the
         instructions are used.  Otherwise, 

         0. The version of alist that this parameter file is designed for.
            If the program finds an old version, it will *upgrade* the
            alistp file.

         1. The first line contains one line with two integers defining the
         range of basesto display.  This allows one to have a wide alignment,
         but look only at a portion.

         2. If the first character of the second line is:  'p' the piece name
            and coordinates are given in the list.  If it is ' ' then neither
            is given.  If one has only one piece that one is working with,
            one may not want the piece name but will want the coordinate
            In this case use 'c'.

            If the second character is 'l', then the
            long name of the piece is given in the list preceeding the piece
            name.  Note that this long name can be written into the book from
            the instructions by the Delila "name" instruction.  (See <NAME> in
            the libdef.)  Blank names (ie, 'name "";') are accepted.

            If the third character is not '-', then the sequences are
            numbered.  If it is '-' they are not.

         3. If the first character of the third line is 'n' then paging is not
         done to the list.

         4. If the first character of the fourth line is
            'f' (for 'first') then the sequences are always aligned by their
            first base.

            'i' then the sequences are aligned by the delila instructions.  If
            the inst file is empty, alignment is forced to the 'b' mode.

            'b' (for 'internal') then the alignment is on the internal zero of
            the book's sequence.  This option is to be used when "default
            coordinate zero" is used in the Delila instructions.

            The following table should clarify the cases and their uses:

      state |instructions empty |              instructions exist 
      ------|-------------------|-------------------------------------------
            |                   |  instruction alignment |  book alignment
            |                   |  (def coo nor)         |  (def coo zer)
            |-------------------|------------------------|------------------
        'f' |    first base     |  first base            |  first base
            |   (first base)    | (first base)           | (first base)
            |-------------------|------------------------|------------------
        'i' |    book           |  inst                  |  inst (DO NOT USE)
            |    (0)            | (aligning base)        |  (aligning base)
            |-------------------|------------------------|------------------
        'b' |    book           |  book (DO NOT USE)     |  book
            |    (0)            | (0)                    |  (0)

        The first line of each entry defines how the alignment will be
        assigned.  Thus 'f' forces the first base to be used at all times and
        'b' forces the book to be used.  In two case this does not make sense.
        First, if the instructions were generated with the "default coordinate
        zero", then the Delila instructions do not correspond to the base
        coordinates in the book (by definition) and so the alignment should not
        use the instruction file.  In the second case, the instructions use
        "default coordinate normal" so the zero base in the book does not
        correspond to the zero base in the instructions.  The basic problem
        here is that there is no way for the program to know which situation
        occurs, without spending time reading the Delila instructions.  So the
        user must specify.  (This may be automated in the future.)

        The second line of each entry is the coordinate number which appears on
        the left column of the aligned listing.

        5. Column number to read from avalues file (integer),
           followed by the field width and number of decimal places to write
           the values to the list and clist.

        6. edgecontrol edgeleft, edgeright, edgelow, edgehigh:
             edgecontrol is a single character that controls how the bounding
             box of the figure is handled.  If it is 'p' then the bounding
             box will be the page parameters defined in constants inside the
             program (llx, lly, urx, ury).  Otherwise, there are four real
             numbers that define the edges around the clist in cm.  To allow
             a clist to be imbedded into another figure, its size must be
             defined in PostScript (with %%BoundingBox).  By setting these
             four numbers, the edges are defined.

        7. map control: A series of values:
         * mapcontrol: If the first character on the line is a 'C', then the
           color map file will be written.  If it is 'R' then the page will
           be set up so that the upper left corner is moved to the lower left
           corner and the image is rotated 90 degrees counter clockwise.
           This has the effect of making the image in "landscape" mode.

         * fontsize (integer): The character height in points (there
           are 72 points/inch, 2.54 cm/inch).  Typical value for alist: 15.

        8. deltaXcm deltaYcm scaleimage: image positioning controls

         * deltaXcm: The amount to move the image in X (cm).
         * deltaYcm: The amount to move the image in Y (cm).
         * scaleimage: the scaling factor.

         The image will be shifted on the printed page.  X is positive to the
         right and Y is positive up the page.  Generally one would use
         positive values for X and negative values of Y since the image
         should otherwise fit snugly in the upper left corner of the page.

         The scaling is performed after movement from the lower left hand
         corner of the image as one would read it.  If the image has been put
         in "landscape" mode the delta-shifts are given in the new coordinate
         system.  This allows one to switch between "landscape" and regular
         "portrait" mode without changing the parameters, and it allows one
         to think in terms of a normally held page.

        9. headercontrol: the first character on the line determines
         whether the header description is written to list and clist.
         If the character is 'h' it is written, otherwise not.
         Headers can also be removed from the clist by deleting lines
         containing the word "NOHEADER".  In Unix this is done by:

            grep -v clist NOHEADER > clist.noheader

         With 'h' the numbar (bar of vertically written numbers) is included
         above the sequence, but if the character is '0' (zero) the numbar is
         not written.  This allows one to use the list file to extract column
         data easily, otherwise it is not recommended.

      namebook: names of genes or transcripts from this book appear in
         the list.  If namebook is empty, then only the items specified in
         alistp are given.

      namelist: if this file is not empty, then it should contain a simple list
         of names to give to each sequence listed.  These are placed to the
         left of the alist and may contain anything one wants.  The number of
         columns used is determined by the longest line in the file.

      avalues: Aligned list values.  A file containing values to list for
         each of the sequences.  If the file is not empty, the values appear
         to the right of the sequences.  The first line of the file is
         expected to begin with "* " followed by the title of the values.
         All other lines that begin with "*" are ignored.  The program uses
         the data column of avalues as defined in the alistp parameter file.

      list: the aligned listing

      clist: the aligned listing, in PostScript color.  Paging is ALWAYS done
         to this file, using the page parameter.  However, it can be removed
         by deleting all lines with the word "REMOVE" on them.  This is
         easily done in Unix with:
            grep -v clist REMOVE

      colors: colors defining the bases, see makelogo for definition.

      output: messages to the user

description

      Alist creates an aligned listing of a sets of sequences.  The pieces in
      the book are aligned according to the instructions in file inst, and
      listed in the list file.  Each piece is identified, and a bar of numbers
      (called a 'numbar') that are read vertically defines the locations of
      bases around the aligning point.

example

      To generate an example input set using namebook, start with a set of
      instructions that name genes and get them (as 'get from gene beginning -0
      to gene beginning +2;').  Produce namebook.  Check for genes that are
      reversed relative to the piece (use hist and alist without instructions),
      and correct the delila instructions.  To convert these instructions to
      absolute form, use program search with 'd f -54321 t +12345 q atg gtg
      ttg' on namebook.  Now convert -54321 and +12345 to the range of interest
      (beware of absolute locations with the same numbers).  Finally, generate
      the book using delila.  (Someday this process will be simpler.)

      Here are some search instructions (file: sea):

 * instructions for the input file of the search program
 d
 q
 #gtt
 ~ =
 q

(The blanks at the beginning of each line protect from the compiler detecting
the # on the first line, and should be removed to try this example.)

When these are given to search along with the book 'exobk':

      cp ex0bk book
      search < sea

The inst file is:

title "95/01/24 21:12:11 search 6.05";
(@ * 86/12/12 13:06:31, 84/05/05 21:12:50, ex0: example
@)
default numbering piece;
default numbering 1;
default out-of-range reduce-range;
default coordinate zero;

(@   typed pattern: "#gtt" @)
organism ecoli; chromosome ecoli;
piece lac;
get from 43 -100 to 43 +100 direction +;
(@ the complementary search string is now: "aa#c" @)

(@   typed pattern: "aa#c" @)
piece lac;
get from 35 +100 to 35 -100 direction -;
get from 42 +100 to 42 -100 direction -;

      (The '*' of comments was converted to '@' so that this page could be a
      comment in the alist source code.) Note the "default coordinate zero"
      which was inserted by hand.  When these instructions are run through
      delila (using ex0bk as the library) and then given to alist with
      parameters alistp:

-10 10      From and To
pl          display control p: piece&coordinate of zero base; l: long name
n           no paging
i           f: first base, i: inst, b: book alignment
6  4  1     avalues: column, output width, output decimals
alistp: parameters for alist 5.54 and heigher

An example list file is:

 alist 6.05, aligned listing of book:
 * 95/01/24 22:43:43, 95/01/24 19:36:00,
   95/01/24 21:12:11 search 6.05
 piece names from:
 * 95/01/24 22:43:43, 95/01/24 19:36:00,
   95/01/24 21:12:11 search 6.05
 The book is from:         0 to 20
 This alignment is from: -30 to 20

           ---------------------                   +++++++++++
           322222222221111111111--------- +++++++++11111111112
           098765432109876543210987654321012345678901234567890
           ...................................................
lac   0  1                 gtgaaaccagtaacgttatac              
lac   0  2                 gtataacgttactggtttcac              
lac   0  3                        gtataacgttactggtttcac 

documentation
      delman.use.aligned.books

see also
      {program that produces the book: } delila.p
      {search program to help locate sites:} search.p

      {example inst:} spliceA.in
      {example book:} spliceA.bk
      {example aligned listing parameter file:} alistp
      {example colors file:} colors

      {To learn about page printer boundaries, go to}
      https://alum.mit.edu/www/toms/postscript.html#tricks

author
      Thomas D. Schneider

bugs

      If you use relative instructions, then alist will bomb.
      Ie, do not use instructions of the form:
          get from gene beginning - 5 to gene beginning +5;

      There is also an unsolved bug in alist:
      When the pieces and instructions are not 'just right', alist will
      produce listings that are thousands of characters wide...  The reason
      for this is not completely clear, but it is related to attempting
      to extend the from-to range of an aligned book, and perhaps to incorrect
      responses of delila when attempting to 'reduce' a piece beginning or
      ending that is off the end of a fragment of a circular piece.  The code
      now contains traps that halt the program when wide listings would have
      been generated.  This bug may have been solved.

      Alist cannot align a sequence if the alignment point is outside the
      sequence.

      Note:  it is possible to use the 'i' mode when "default coordinate zero"
      has been set, but this can lead to confusing output.  There is no simple
      mechanism to prevent this in DelilaI.

      [1995 Dec 7]  The namebook mechanism is currently broken for the clist.

technical notes

   The variable 'nametype' defines the kind of name picked up in namebook.

   The constant 'pagelength' defines the length of the page in the list.

   The constant 'topofpage' defines the top of the page in cm in the clist.

   There are 4 constants that tell the program the printer page boundaries:

   The following bounding box is for the Canon Color Laser Copier 1150.
   defaultllx =   7.10999; default for llx, lower left x
   defaultlly =   7.01995; default for lly, lower left y
   defaulturx = 588.15;    default for urx, upper right x
   defaultury = 784.98;    default for ury, upper right y

   These should be set for your printer.  To see how this is
   done, go to the link given in the See Also.
   Alternatively, you can use the edgecontrol parameter.

   As of version 5.96, alist can sense that a parameter file (alistp) is out
   of date and it will automatically upgrade the file.  For this reason the
   parameter file is now listed as 'inout', meaning that it can be modified
   by this program.

*)
(* end module describe.alist *)

(* begin module alist.const *)
   (* more constants *)
   pagelength = 59; (* the length of pages for the list, in lines *)
   headerlines = 10; (* the number of lines used by list first page header *)
   headerclines = 5; (* the number of lines used by clist page header *)
   maxnumberwidth = 7; (* the width of numbers in the list and clist *)
   columnmax = 20; (* maximum column name in characters *)

   (* bounding box definitions: *)

   (* The following bounding box is for the Canon Color Laser Copier 1150. *)
   defaultllx =   7.10999; (* default for llx, lower left x *)
   defaultlly =   7.01995; (* default for lly, lower left y *)
   defaulturx = 588.15;    (* default for urx, upper right x *)
   defaultury = 784.98;    (* default for ury, upper right y *)

{
   (* The following bounding box is for the Canon Color Laser Copier 800S. *)
   defaultllx =  10.08; (* default for llx, lower left x *)
   defaultlly =   8.91; (* default for lly, lower left y *)
   defaulturx = 588.06; (* default for urx, upper right x *)
   defaultury = 779.85; (* default for ury, upper right y *)
}

{
   (* the following bounding box is for the Tektronix Inkjet Phaser 140 *)
   defaultllx =  14.4; (* default for llx, lower left x *)
   defaultlly =  28.9; (* default for lly, lower left y *)
   defaulturx = 596.8; (* default for urx, upper right x *)
   defaultury = 777.7; (* default for ury, upper right y *)
}

   (* constants to control the edges *)
   deffontsize = 15; (* font size (height) in points (1/72 inch) *)
   defcolorlistcontrol = 'C'; (* normal display *)
   defcharacterratio = 0.60; (* default for the ratio of the rightward
      horizontal motion when a character is drawn to the font height.
      See lister.p for source and more information about this. *)

   topofpage = 27.0; (* top of page in cm *)
   defdeltaXcm = 1.0; (* default X shift in cm *)
   defdeltaYcm = -1.0; (* default Y shift in cm *)
   defscaleimage = 1.0; (* default scale of image *)

(* end module alist.const *)

(* LOCK begin module book.const *)
(* constants needed for book manipulations *)

      dnamax = 300;  (* length of dna arrays *)
      namelength = 100; (* maximum key name length *)
      linelength = 80; (* maximum line readable in book *)

(* LOCK end module book.const version = 'delmod 6.88 98 Jul 10 tds/gds' *)

(* PostScript constants *)
   pwid = 8; (* width in character places to print PostScript numbers *)
   pdec = 5; (* decimal places to print PostScript numbers *)
   pdecolor = 4; (* decimal places for color descriptions (5 WILL CAUSE
                    NeWS 1.1 TO BOMB) *)

(* begin module interact.const *)
(* begin module string.const *)
      maxstring = 2000; (* the maximum string *)
(* end module string.const version = 4.86; (@ of prgmod.p 2004 Sep 8 *)
(* end module interact.const version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module filler.const *)
      fillermax = 50; (* the size of the filler array for a string *)
(* end module filler.const version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

type
(* begin module interact.type *)
(* begin module string.type *)
   stringptr = ^string; (* pointer to a string *)
   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 *)
      next: stringptr; (* the next string in a series *)
   end;
(* end module string.type version = 4.86; (@ of prgmod.p 2004 Sep 8 *)
(* end module interact.type version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module filler.type *)
      (* the following is an array used to fill a string.
      it is convenient to have it much shorter than the maxstring, so that
      it is easy to fill the string using procedure fillstring.
      the user must declare the value of constant fillermax. *)
      filler = packed array[1..fillermax] of char;
(* end module filler.type version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* 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 = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module book.type *)
(* types needed for book manipulations *)

      chset = set of 'a'..'z';

      (* types defined in book definition *)

      alpha = packed array[1..namelength] of char; (* this is not alfa *)

      (* name is a left justified string with blanks following the
         characters *)
      name = record
         letters: alpha;
         length: 0..namelength (* zero means an unspecified structure *)
      end;

      lineptr = ^line;
      line = record (* a line of characters *)
         letters: packed array [1..linelength] of char;
         length: 0..linelength;
         next: lineptr
      end;

      direction = (plus, minus, dircomplement, dirhomologous);
      configuration = (linear, circular);
      state = (on, off);

      header = record (* header of key *)
         keynam: name; (* key name of structure *)
         fulnam: lineptr; (* full name of structure *)
         note:   lineptr (* note key *)
      end;

(* begin module base.type *)
   (* define the four nucleotide bases *)
   base = (a,c,g,t);
(* end module base.type version = 7.74; {of delmod.p 2013 Jan 17} *)

      (* sequence types *)
      dnaptr = ^dnastring;
      dnarange = 0..dnamax;
      seq = packed array[1..dnamax] of base;
      dnastring = record
         part: seq;
         length: dnarange;
         next: dnaptr
      end;


      orgkey = record (* organism key *)
         hea: header;
         mapunit: lineptr (* genetic map units *)
      end;

      chrkey = record (* chromosome key *)
         hea: header;
         mapbeg: real; (* number of genetic map beginning *)
         mapend: real (* number of genetic map ending *)
      end;

      pieceptr = ^piece;
      piekey = record (* piece key *)
         hea: header;
         mapbeg: real; (* genetic map beginning *)
         coocon: configuration; (* configruation (circular/linear) *)
         coodir: direction; (* direction (+/-) relative to genetic map *)
         coobeg: integer; (* beginning nucleotide *)
         cooend: integer; (* ending nucleotide *)
         piecon: configuration; (* configruation (circular/linear) *)
         piedir: direction; (* direction (+/-) relative to coordinates *)
         piebeg: integer; (* beginning nucleotide *)
         pieend: integer; (* ending nucleotide *)
      end;


      piece = record
         key: piekey;
         dna: dnaptr
      end;

      reference = record
         pienam : name;  (* name of piece referred to *)
         mapbeg : real;  (* genetic map beginning *)
         refdir : direction;  (* direction relative to coordinates *)
         refbeg : integer;  (* beginning nucleotide *)
         refend : integer;  (* ending nucleotide *)
      end;

      genkey = record  (* gene key *)
         hea : header;
         ref : reference;
      end;

      trakey = record  (* transcript key *)
         hea : header;
         ref : reference;
      end;

      markerptr = ^marker;
      markey = record (* marker key *)
         hea : header;
         ref : reference;
         sta : state;
         phenotype : lineptr;
         next : markerptr;
      end;

      marker = record
         key : markey;
         dna : dnaptr;
      end;

(* end module book.type version = 7.74; {of delmod.p 2013 Jan 17} *)


var
      inst, (* the delila instructions required by the align procedures *)
      book, (* the book to be aligned *)
      alistp, (* parameters to constrol the program *)
      namebook, (* a book from which to draw names of pieces listed *)
      namelist, (* a list of names *)
      avalues, (* values to list *)
      list, (* the resulting aligned listing *)
      clist, (* the resulting aligned listing, in color PostScript *)
      colors: (* colors PostScript *)
         text;

      (* variables used by the align routines: *)
      apiece: pieceptr;
      length, alignedbase: integer;
      fromparam, toparam: integer;

      fromdo, todo: integer; (* user defined range to use *)
      userrange: boolean; (* if true, the user defined range is used *)
      displaylevel: char; (* defines how much information to put on the display
                             'p' means put piece name and zero coordinate *)
      shownumbers: char; (* if '-' don't show the number of a piece,
         otherwise show the number in the book *)

      usefullname: char; (* defines whether to use the long name from the book
                           'l' means use it *)
      fullnamewidth: integer; (* length of the longest fullname in the book *)
      paging: char; (* defines whether to do pages.  If 'n' no pages are done *)

      index: integer; (* aligned space index *)
      indexfill: integer; (* index for filling out the namelist *)

      cpagelength: integer; (* the length of pages for the clist, in lines.
         This used to be hardwired to 47, but now is computed from the
         bounding box information defaultlly and defaultury in startpostscript. *)

      linenumber: integer; (* line of the page we are on *)
      clinenumber: integer; (* line of the page we are on in color *)
{
      headerlinenumber: integer; (* header length for list *)
this is not used 
}
      (* the number of lines used by the first page header of clist: *)
      headerclinenumber: integer;

      pagenumber: integer; (* the page number *)
      cpagenumber: integer; (* the page number *)

      (* used by procedures maxname and printname for getocp *)
      org: orgkey;   orgchange, orgopen: boolean;
      chr: chrkey;   chrchange, chropen: boolean;
      pie: pieceptr; piechange, pieopen: boolean;

      nametype: char; (* the type of name to look for in namebook.
                         it can be 'g', 't', or 'p'. *)
      namewidth: integer; (* the amount of space to allocate to names *)
      namelistwidth: integer; (* space to allocate for names in namelist *)
      namelistuse: boolean; (* use namelist?  Use this test instead of
         emptyfile since it does NOT reset the file each time! *)
      numberwidth: integer; (* the width of numbers in the list and clist *)
      positionwidth: integer; (* the width of position numbers *)
      sequences: integer; (* the number of sequences in the book *)

      b: char; (* a base to print out *)
      column: integer; (* counts the column of the printout so that
         color PostScript won't have really huge lines *)

      alignmenttype: char; (* 'f' means alignment by First internal
         coordinate    base, 'b' means alignment by Book, 'i' means
         alignment by Instructions *)

      cnamelist: char; (* a character for reading and writing namelist *)
      programname: name; (* the name of this program *)
      thedirection: char; (* the direction of the piece to report *)

      readvalues: boolean; (* whether to read values from file avalues *)
      columnname: array[1..columnmax] of char; (* column name *)
      columnlength: integer; (* current length of the columnname *)
      columntoread: integer; (* the column to read from avalues *)
      columnwid: integer; (* the character width of the avalues column to write *)
      columndec: integer; (* the decimal places of the avalues column to write *)
      columnvalue: real; (* a value from the column of avalues *)

   theline: integer; (* current line in the book *)
   parameterversion: real; (* parameter version number *)

   (* variables to control the postscript display *)
   llx: real; (* lower left x *)
   lly: real; (* lower left y *)
   urx: real; (* upper left x *)
   ury: real; (* upper left y *)
   edgecontrol: char; (* if 'p' then use page instead of edges *)
   edgeleft, edgeright, edgelow, edgehigh: real; (* edges around the clist *)
   blanks: integer; (* the number of blanks before the numbar *)
   displaywidth: integer; (* total width of display in characters *)

   cmfactor: real; (* convert from cm to points *)

   { not used:
   fontsizecm: real; (* font size in cm *)
   }
   fontsize: integer; (* font size in points (1/72 inch) *)

   colorlistcontrol: char; (* control map production *)
   mapcontrol: boolean; (* true if colorlistcontrol = 'C' or 'R' *)
   deltaXcm: real; (* amount to move the entire page in X *)
   deltaYcm: real; (* amount to move the entire page in Y *)
   scaleimage: real; (* amount to scale the entire page from upper left
                        corner *)

   headercontrol: char; (* control the header, 'h' means produce the header *)

(* begin module book.var *)
(* ************************************************************************ *)
(* global variables needed for book manipulations *)

      (* free storage: *)
      freeline: lineptr; (* unused lines *)
      freedna: dnaptr; (* unused dnas *)

      readnumber: boolean; (* whether to read a number from the notes, or
                              to read in the notes *)
      number: integer; (* the number of the item just read *)
      numbered: boolean; (* true when the item just read is numbered *)
      skipunnum: boolean; (* a control variable to allow skipping of
                             un-numbered items in the book *)

(* ************************************************************************ *)
(* end module book.var version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module crash *)
procedure crash;
(* Crash the program by trying to open a nonexistant file.  This allows
tracing by the dbx program.  To use:  insert call into the halt program
or whereever a traceable stop is desired. *)
var
   bogus: text; (* boghous internal file *)
begin
  writeln(output,' program crash.');
  reset(bogus);
end;
(* end module crash version = 7.74; {of delmod.p 2013 Jan 17} *)

(* 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 = 7.74; {of delmod.p 2013 Jan 17} *)

(* 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 = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module copynoreturn *)
procedure copynoreturn(var fin, fout: text);
(* copy a line from file fin to file fout
but don't put a carriage return *)
begin (* copynoreturn *)
      while not eoln(fin) do begin
         fout^ := fin^;
         put(fout);
         get(fin)
      end;
      readln(fin);
(*      writeln(fout); *)
end; (* copynoreturn *)
(* end module copynoreturn *)

(* begin module copytocomma *)
procedure copytocomma(var fin, fout: text);
(* copy a line from file fin to file fout
only up to a comma and don't put a carriage return if found *)
var
   done: boolean; (* done copying *)
begin (* copynoreturn *)
   done := false;
   while not done do begin
      if eoln(fin) then begin
         done := true;
         readln(fin);
      end
      else begin
         if fin^ = ',' then done := true;
         fout^ := fin^;
         put(fout);
         get(fin)
      end
   end;
end; (* copytocomma *)
(* end module copytocomma *)

(* begin module splitbooktitle *)
procedure splitbooktitle(var book, list: text);
(* copy the title of the book  to the list, but split the title line up:
 * 2000/06/21 00:40:04, 1999/05/11 16:29:30,
  OxyR version = 2.12 of inst.oxyr 2000 June 21
*)
begin
   reset(book);
   copytocomma(book, list);
   copytocomma(book, list);
   writeln(list);
   write(list,' ');
   copyaline(book, list);
end;
(* end module splitbooktitle *)

(******************************************************************************)
(******************************************************************************)
(******************************************************************************)

(* begin module package.trigger *)
(* ************************************************************************ *)

(* begin module clearstring *)
(* These modules clear strings in various ways *)
(* ---- *)
procedure emptystring(var ribbon: string);
(* empty the contents of the string but do NOT
remove the pointer.  This is useful for clearing
one string within a linked list of them. *)
var   index: integer; (* to the ribbon *)
begin (* clearstring *)
   with ribbon do begin
      for index := 1 to maxstring do letters[index] := ' ';
      length := 0;
      current := 0;
   end
end; (* emptystring *)
(* ---- *)
procedure clearstring(var ribbon: string);
(* empty the string and remove the pointer *)
begin (* clearstring *)
   with ribbon do begin
      emptystring(ribbon);
      next := nil;
   end
end; (* clearstring *)
(* ---- *)
procedure initializestring(var ribbon: string);
(* start the string with a nil pointer.   This routine
should be called before doing linked list work.  This allows
the standard string routines to clear the string without
killing the pointer.  This is now deprecated, do not use it
since clearstring still clears the next pointer. *)
begin (* initializestring *)
   writeln(output,'remove initializestring routine!');
   writeln(output,'replace it with clearstring routine!');
   halt; (* to force deprecation *)
   clearstring(ribbon);
   ribbon.next := nil;
end; (* initializestring *)
(* end module clearstring version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module writestring *)
procedure writestring(var tofile: text; var s: string);
(* write the string s to file tofile, no writeln *)
var   i: integer; (* index to s *)
begin (* writestring *)
      with s do for i := 1 to length do write(tofile, letters[i])
end; (* writestring *)
(* end module writestring version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module filler.fillstring *)
procedure fillstring(var s: string; a: filler);
(* this procedure makes it reasonably easy to fill the string s with
characters.  one calls the procedure as: *)
(*                           1         2         3         4         5 *)
(*                  12345678901234567890123456789012345678901234567890 *)
(*   fillstring(s, 'this-is-the-string                                ');
the two comments make it easy to line the characters up. also, for this
example, it was assumed that the length of filler as defined by the
constant fillermax was 50. *)
var
      length: integer; (* of the string without trailing blanks *)
      index: integer; (* of s *)
begin (* fillstring *)
      clearstring(s);
      length := fillermax;
      while (length > 1) and (a[length] = ' ') do length := pred(length);
      if (length = 1) and (a[length] = ' ') then begin
         writeln(output, 'fillstring: the string is empty');
         halt
      end;

      for index := 1 to length do s.letters[index] := a[index];
      s.length := length;
      s.current := 1
end; (* fillstring *)
(* end module filler.fillstring version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module filler.filltrigger *)
procedure filltrigger(var t: trigger;
                      a: filler);
(* fill the trigger t *)
begin (* filltrigger *)
         fillstring(t.seek,a)
end; (* fillstring *)
(* end module filler.filltrigger version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* 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.
1996 Sep 12: Bug found!  In the case of a trigger "ab", the program
used to miss it for situations like "aab".  This was because at the
first a it would step up.  Then it would see the second a and recognize
that was not part of ab.  It would fail to realize that it could be
the start of a new one.  The code now accounts for that possibility. *)
begin (* testfortrigger *)
      with t do begin
         state := succ(state);
{
writestring(list,seek);
writeln(list,'testfortrigger seek.letters[',state:1,']:',
seek.letters[state],' ch:',ch);
}
         if seek.letters[state] = ch
         then begin
            skip := false;
            if state = seek.length then found := true
                                   else found := false
         end
         else begin
            (* it failed.  But wait!  It could be the beginning
            of a NEW trigger string! *)
            if seek.letters[1] = ch then begin
               state := 1;
               skip := false;
               found := false
            end
            else begin (* reset trigger *)
               state := 0;
               skip := true;
               found := false
            end
         end
      end
end; (* testfortrigger *)
(* end module trigger.proc version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module skipblanks *)

(* 2003 July 31: tab is considered a blank character *)

function isblank(c: char): boolean;
(* is the character c blank or tab? *)
const
   tab = 9; (* tab character *)
begin
   isblank := (c = ' ') or (ord(c) = tab)
end;

procedure skipblanks(var thefile: text);
(* skip over blanks until a non-blank, or end of line, is found *)
begin
   while isblank(thefile^) and not eoln(thefile) do get(thefile);
end;

procedure skipnonblanks(var thefile: text);
(* skip over nonblanks until a blank, or end of line, is found *)
begin
   while (not isblank(thefile^)) and not eoln(thefile) do get(thefile);
end;

procedure skipcolumn(var thefile: text);
(* skip over a data column *)
begin
   skipblanks(thefile); skipnonblanks(thefile)
end;
(* end module skipblanks version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* ************************************************************************ *)
(* end module package.trigger version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(******************************************************************************)
(******************************************************************************)
(******************************************************************************)

(* begin module package.align *)
(* ************************************************************************ *)
(* begin module package.getpiece *)
(* ************************************************************************ *)
(* begin module package.brpiece *)
(* ************************************************************************ *)
(* begin module book.basis *)
(* procedures needed for book manipulations *)

(* get procedures should be used for all linked lists of records *)

procedure getline(var l: lineptr);
(* obtain a line from the free line list or by making a new one *)
begin
      if freeline<>nil
         then begin
            l:=freeline;
            freeline:=freeline^.next
         end
         else new(l);
      l^.length:=0;
      l^.next:=nil
end;

procedure getdna(var l: dnaptr);
begin
      if freedna<>nil
         then begin
            l:=freedna;
            freedna:=freedna^.next
         end
         else new(l);
      l^.length:=0;
      l^.next:=nil
end;

(* clear procedures should be called each time the records are no longer needed
         failure to do this may result in a stack overflow. *)

procedure clearline(var l: lineptr);
(* return a line to the free line list *)
var   lptr: lineptr;
begin
      if l<>nil then begin
         lptr:=l;
         l:=l^.next;
         lptr^.next:=freeline;
         freeline:=lptr
      end
end;

procedure writeline(var afile: text; l: lineptr;
                        carriagereturn: boolean);
(* write a line to a file, with carriage return if
carriagereturn is true. *)
var
   index: integer; (* index to characters in l *)
begin
   with l^ do begin
      for index := 1 to length
      do write(afile, letters[index]);
   end;
   if carriagereturn then writeln(afile);
end;

procedure showfreedna;
(* show the freedna list *)
var
   counter: integer; (* count of freedna list *)
   l: dnaptr; (* pointer into freedna list *)
begin
   l := freedna;
   counter := 0;
   while l <> nil do begin
      counter := succ(counter);
      write(output,counter:1);
      write(output, ', length = ',l^.length:1);
{
This is illegal according to gpc because one cannot
write a pointer to a text file.  It can be unearthed
for debugging.
      write(output, ', pointer id: ',l:1);
}
      writeln(output);
      l := l^.next
   end;
end;

procedure cleardna(var l: dnaptr);
(* clear the dna strutures to the free list *)
var   lptr: dnaptr;
begin
      if l<>nil then begin
         lptr:=l;
         l:=l^.next;
         lptr^.next:=freedna;
         freedna:=lptr
      end
end;

procedure clearheader(var h: header);
(* clear the header h (remove lines to free storage) *)
begin
      with h do begin
         clearline(fulnam);
         while note<>nil do clearline(note)
      end
end;

procedure clearpiece(var p: pieceptr);
(* clear the dna of the piece *)
begin
      while p^.dna<>nil do cleardna(p^.dna);
      clearheader(p^.key.hea)
end;

function chartobase(ch:char):base;
(* convert a character into a base *)
begin
      case ch of
         'a': chartobase:=a;
         'c': chartobase:=c;
         'g': chartobase:=g;
         't': chartobase:=t
      end
end;

function basetochar(ba:base):char;
(* convert a base into a character *)
begin
      case ba of
         a: basetochar:='a';
         c: basetochar:='c';
         g: basetochar:='g';
         t: basetochar:='t';
      end
end;

function complement(ba:base):base;
(* take the complement of ba *)
begin
      case ba of
         a: complement:=t;
         c: complement:=g;
         g: complement:=c;
         t: complement:=a;
      end
end;

function chomplement(b: char): char;
(* create the character complement of base b.  I must be getting hungry! *)
begin
  chomplement := basetochar(complement(chartobase(b)));
end;

function pietoint(p: integer; pie: pieceptr): integer;
(* p is a coordinate on the piece.
   we want to transform p into a number
   from 1 to n: an internal coordinate system for
   easy manipulation of piece coordinates *)
(* Note: the dirhomologous and dircomplement are treated as
plus and minus directions, which MIGHT NOT BE RIGHT! *)
var   i: integer; (* an intermediate value *)
begin
      with pie^.key do begin
         case piedir of
            dirhomologous,
            plus:  if p>=piebeg
                   then i:=p-piebeg+1
                   else i:=(p-coobeg)+(cooend-piebeg)+2;
            dircomplement,
            minus: if p<=piebeg
                   then i:=piebeg-p+1
                   else i:=(cooend-p)+(piebeg-coobeg)+2
         end;
         pietoint:=i
      end
end;

function inttopie(i: integer; pie: pieceptr):integer;
(* i is in the range 1 to some maximum.  it is an internal coordinate
   system for the program.  we want to do a
   coordinate transformation to obtain
   a value in the range of the piece called pie:
   i=1 corresponds to piebeg and
   i=its maximum corresponds to pieend *)
(* Note: the dirhomologous and dircomplement are treated as
plus and minus directions, which MIGHT NOT BE RIGHT! *)
var   p: integer; (* an intermediate value *)
begin
      with pie^.key do begin
         case piedir of
            dirhomologous,
            plus: begin
               p:=piebeg+(i-1);
               if p>cooend
                  then if coocon=circular
                     then p:=p-(cooend-coobeg+1)
            end;
            dircomplement,
            minus: begin
               p:=piebeg-(i-1);
               if p<coobeg
                  then if coocon=circular
                     then p:=p+(cooend-coobeg+1)
            end
         end;
         inttopie:=p
      end
end;

function piecelength(pie: pieceptr): integer;
(* return the length of the dna in pie *)
begin
      piecelength:=pietoint(pie^.key.pieend,pie)
end;

(* end module book.basis version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.getto *)
function getto(var thefile: text; var theline: integer; ch: chset): char;
(* search the file for a character in the first line which is a
   member of the set ch.
Note:  on 1999 March 10 the definition of this function was cleaned
up.  Instead of putting thefile on the line AFTER the charcter ch
has been found, it puts thefile ON the line.  Other routines like
brdna and brpiece have to move to the next line themselves.  This makes
getto give the OBJECT.  *)
var
   achar: char; (* a character in thefile *)
   done: boolean; (* done finding achar *)
begin
   achar:=' ';
   done := false;
   while not done do begin
      if eof(thefile)
      then done := true
      else begin
         achar := thefile^;
         if achar in ch
         then done := true
         else begin
            readln(thefile);
            theline := succ(theline)
         end
      end
   end;
   if (achar in ch) then getto:=achar
                    else getto:=' '
{ The old method -
      while (not(achar in ch)) and (not eof(thefile))
         do begin
            readln(thefile,achar);
            theline := succ(theline)
         end;
   if (achar in ch) then getto:=achar
                    else getto:=' '
}
end;
(* end module book.getto version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.skipstar *)
procedure skipstar(var thefile: text);
(* skip start of line (or star = '*'). *)
begin (* skipstar *)
   if eof(thefile) then begin
      writeln(output,' procedure skipstar: end of book found');
      halt
   end
   else begin
      if thefile^ <> '*' then begin
         writeln(output,' procedure skipstar: bad book');
         writeln(output,' "*" expected as first character on the line, but "',
                        thefile^,'" was found');
         halt
      end;
      get(thefile); (* skip the star *)
      if thefile^ <> ' ' then begin
         writeln(output,' procedure skipstar: bad book');
         writeln(output,' "* " expected on a line but "*',
                        thefile^,'" was found');
         halt
      end;
      get(thefile) (* skip the blank *)
   end
end; (* skipstar *)
(* end module book.skipstar version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brreanum *)
procedure brreanum(var thefile: text; var theline: integer; var reanum: real);
(* read a real number from the file *)
begin
      skipstar(thefile);
      readln(thefile,reanum);
      theline := succ(theline)
end;
(* end module book.brreanum version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brnumber *)
procedure brnumber(var thefile: text; var theline: integer; var num: integer);
(* read a number from the file *)
begin
      skipstar(thefile);
      readln(thefile,num);
      theline := succ(theline)
end;
(* end module book.brnumber version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brname *)
procedure brname(var thefile: text; var theline: integer; var nam: name);
(* read a name from the file *)
var   i: integer; (* an index to the name *)
      c: char; (* a character read *)
begin (* brname *)
      skipstar(thefile);
      with nam do begin
         length:=0;
         repeat
            length:=succ(length);
            read(thefile,c);
            letters[length] := c
         until (eoln(thefile)) or
               (length>=namelength) or
               (letters[length]=' ');
         if letters[length]=' ' then length:=length-1;
         if length<namelength
            then for i:=length+1 to namelength do letters[i]:=' '
      end;
      readln(thefile);
      theline := succ(theline)
end; (* brname *)
(* end module book.brname version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brline *)
procedure brline(var thefile: text; var theline: integer; var l: lineptr);
(* read a line from the file *)
var
      i: integer;
      acharacter: char;
begin
      skipstar(thefile);
      i:=0;
      (* protection added 2005 Sep 15 *)
      while (not eoln(thefile)) and (i < linelength)  do begin
         i:=succ(i);
         read(thefile,acharacter);
         l^.letters[i]:=acharacter
      end;
      (* protection added 2005 Sep 15 *)
      if not eoln(thefile) then begin
         writeln(output,'***********************************************');
         writeln(output,'* WARNING: brline: book line length exceeded');
         writeln(output,'* linelength > ',linelength:1,' characters');
         writeln(output,'* Only ',linelength:1,' characters read from book');
         writeln(output,'***********************************************');
      end;
      l^.length:=i;
      l^.next:=nil;
      readln(thefile);
      theline := succ(theline)
end;
(* end module book.brline version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brdirect *)
procedure brdirect(var thefile: text; var theline: integer; var direct: direction);
(* read a direction *)
var   ch: char;
begin
      skipstar(thefile);
      readln(thefile,ch);
      theline := succ(theline);
      if ch='+' then direct:=plus
                else direct:=minus
end;
(* end module book.brdirect version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brconfig *)
procedure brconfig(var thefile: text; var theline: integer; var config: configuration);
(* read a configuration *)
var   ch: char;
begin
      skipstar(thefile);
      readln(thefile,ch);
      theline := succ(theline);
      if ch='l' then config:=linear
                else config:=circular
end;
(* end module book.brconfig version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brnotenumber *)
procedure brnotenumber(var thefile: text; var theline: integer; var note: lineptr);
(* book note reading to obtain the number of the object.
the procedure returns the value of the number as a global.
(this is not such a good practice, but we are stuck with it for now.) *)
begin (* brnotenumber *)
      note:=nil;
      numbered := false;
      number := 0; (* force number to zero if there
         is no number at all *)
      (* the next character is n or * depending on whether there are notes *)
      if thefile^ = 'n' then begin
         readln(thefile);
         theline := succ(theline);
         if thefile^ <> 'n' then begin
            skipstar(thefile);
            if not eoln(thefile) then begin
               if thefile^ = '#' then begin
                  numbered := true;
                  get(thefile); (* move past the number symbol *)
                  read(thefile,number);
               end
            end;
            repeat
               readln(thefile);
               theline := succ(theline)
            until thefile^ = 'n';
            readln(thefile);
            theline := succ(theline)
         end
         else begin
            readln(thefile);
            theline := succ(theline)
         end
      end
end; (* brnotenumber *)
(* end module book.brnotenumber version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brnote *)
procedure brnote(var thefile: text; var theline: integer; var note: lineptr);
(* read note key *)
var
      newnote: lineptr; (* the new note *)
      previousnote: lineptr; (* the last line of the notes *)
begin (* brnote *)
      note:=nil;
      if thefile^ = 'n' then begin (* enter note *)
         readln(thefile);
         theline := succ(theline);
         if thefile^ <> 'n' then begin (* abort null note (n/n) *)
            getline(note);
            newnote:=note;
            while thefile^ <> 'n' do begin (* wait until end of note *)
               brline(thefile,theline,newnote);
               previousnote:=newnote;
               (* get next note *)
               getline(newnote^.next);
               newnote:=newnote^.next;
            end;
            (* last note was not used, so: *)
            clearline(newnote);
            previousnote^.next:=nil;
            readln(thefile);
            theline := succ(theline);
         end
         else begin
            readln(thefile);
            theline := succ(theline);
         end;
      end
end; (* brnote *)
(* end module book.brnote version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brheader *)
procedure brheader(var thefile: text; var theline: integer; var hea: header);
(* read the header of a key. *)
begin
      with hea do begin
         readln(thefile); (* move past the object name - new definition 1999 Mar 13 *)
         theline := succ(theline);
{bbb}
         (* read key name *)
         brname(thefile,theline,keynam);

         (* read full name *)
         getline(fulnam);
         brline(thefile,theline,fulnam);

         (* read note key *)
         if readnumber then brnotenumber(thefile,theline,note)
                       else brnote(thefile,theline,note)
      end
end;
(* end module book.brheader version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.copyheader *)
procedure copyheader(fromhea: header; var tohea: header);
(* copy the header fromhea into tohea.  Note that the
linked objects are NOT copied, but merely pointed to. *)
begin
   tohea.keynam.letters := fromhea.keynam.letters;
   tohea.keynam.length  := fromhea.keynam.length;
   tohea.note           := fromhea.note;
   tohea.fulnam         := fromhea.fulnam;
end;
(* end module book.copyheader version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brpiekey *)
procedure brpiekey(var thefile: text; var theline: integer; var pie: piekey);
(* read piece key, track the line number *)
begin
      with pie do begin
         brheader(thefile,theline,hea);
         brreanum(thefile,theline,mapbeg);
         brconfig(thefile,theline,coocon);
         brdirect(thefile,theline,coodir);
         brnumber(thefile,theline,coobeg);
         brnumber(thefile,theline,cooend);
         brconfig(thefile,theline,piecon);
         brdirect(thefile,theline,piedir);
         brnumber(thefile,theline,piebeg);
         brnumber(thefile,theline,pieend);
      end
end;
(* end module book.brpiekey version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brdna *)
procedure brdna(var thefile: text; var theline: integer; var dna: dnaptr);
(* read in dna from thefile, track the line *)
(* note: if the dna were circularized, by linking the last dnastring
to the first, then the cleardna routine could not clear properly,
and would loop forever... there is no reason to do that, since a simple
mod function will allow one to access the circle. *)
var
      ch: char;
      workdna: dnaptr;
begin
      getdna(dna);
      workdna:=dna;
      ch:=getto(thefile,theline,['d']);
      readln(thefile);
      theline := succ(theline);
      read(thefile,ch); (* skipstar *)
      while (ch = '*') do
      begin
         read(thefile,ch); (* skip blank *)
         repeat
            read(thefile,ch);
            if ch in ['a','c','g','t'] then begin
               if workdna^.length=dnamax then begin
                  getdna(workdna^.next);
                  workdna:=workdna^.next
               end;
               workdna^.length:=succ(workdna^.length);
               workdna^.part[workdna^.length]:=chartobase(ch)
            end
         until eoln(thefile);
         readln(thefile); (* go to next line *)
         theline := succ(theline);
         read(thefile,ch); (* ch is either '*' or 'd' *)
      end;
      readln(thefile); (* read past the d *)
      theline := succ(theline);
end;
(* end module book.brdna version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brpiece *)
procedure brpiece(var thefile: text; var theline: integer; var pie: pieceptr);
(* read in a piece, change theline to reflect the lines traversed *)
begin
{
   readln(thefile); (* move past the word 'piece' - new definition 1999 Mar 13 *)
   theline := succ(theline); (* BUG: was below! *)
bbb}
   brpiekey(thefile,theline,pie^.key);
   if numbered or (not skipunnum)
   then brdna(thefile,theline,pie^.dna);
   readln(thefile); (* move past the word 'piece' - new definition 1999 Mar 13 *)
   theline := succ(theline);
end;
(* end module book.brpiece version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brinit *)
procedure brinit(var book: text; var theline: integer);
(* check that the book is ok to read, and
   set up the global variables for br routines *)
begin (* brinit *)
      (* halt if the book is bad (first word is 'halt') or the first
         character is not * *)
      reset(book);
      if not eof(book) then begin
         (* check for the date line *)
         if book^ <> '*' then begin
            if book^ <> 'h'
            then writeln(output, ' this is not the first line of a book:')
            else writeln(output, ' bad book:');
            write(output, ' ');

            while not (eoln(book) or eof(book)) do begin
               write(output, book^);
               get(book)
            end;
            writeln(output);
            halt
         end
      end
      else begin
         writeln(output, ' book is empty');
         halt
      end;

      (* initialize free storage *)
      freeline:=nil;
      freedna:=nil;

      readnumber:=true; (* usually we read in numbers for items *)
      number:=0; (* arbitrary value *)
      numbered:=false; (* the piece has no number (none yet read in) *)
      skipunnum:=false;
   theline := 1;
end; (* brinit *)
(* end module book.brinit version = 7.74; {of delmod.p 2013 Jan 17} *)

(* ************************************************************************ *)
(* end module package.brpiece version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.getpiece *)
procedure getpiece(var thefile: text; var theline: integer; var pie: pieceptr);
(* move to and read in the next piece in the book *)
var   ch: char;
begin
   ch:=getto(thefile,theline,['p']); (* get to the next p(iece) in the book *)
   if ch<>' ' then begin
      brpiece(thefile,theline,pie);
{
1999 june 2: removed this:
      ch:=getto(thefile,theline,['p']); (* read to end of p *)
}
{
bbb - now done in brpiece
      readln(thefile); (* read past piece *)
      theline := succ(theline);
}
   end
   else clearpiece(pie);
end;
(* end module book.getpiece version = 7.74; {of delmod.p 2013 Jan 17} *)

(* ************************************************************************ *)
(* end module package.getpiece version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module findblank *)
procedure findblank(var afile: text);
(* read a file to find the next blank character *)
var   ch: char;
begin
      repeat read(afile,ch) until ch = ' '
end;
(* end module findblank version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module findnonblank *)
procedure findnonblank(var afile: text; var ch: char);
(* find the next non blank character in a file, return it in ch. *)
begin
      ch:=' ';
      while (not eof(afile)) and
            (ch = ' ')
      do begin
         read(afile,ch);
         if eoln(afile) then readln(afile)
      end
end;
(* end module findnonblank version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module align.align *)
procedure align(var inst, book: text; var theline: integer;
                var pie:  pieceptr;
                var length, alignedbase: integer);
(* documentation on align is in module info.align and
delman.use.aligned.books.
1996 Sep 12: The routine now uses the trigger functions found
in prgmod.  The bug in the oldalign routine (that it misses the
end of comments that end in a series of asterisks) has been fixed.
It now checks that the piece corresponds to the book. *)
const maximumrange = 10000; (* if the alignment point is more than this
   distance from the piece ends, the program halts in an attempt to catch
   the alignment bug... 1991 Jan 11 It appears that the rewrite of the
   code has removed the bug, but the check will be kept. *)
   semicolon = ';'; (* end of delila instruction *)
var
   ch: char; (* a character in inst *)
   p: integer; (* index to a piece name *)
   p1: integer; (* another index to a piece name *)
   done: boolean; (* done finding an aligning get *)
   thebase: integer; (* the base read in *)
   indefault: boolean; (* true when within a default statement.  These
      can contain the word 'piece', which must be ignored. *)

   gettrigger: trigger; (* trigger to find 'get' *)
   defaulttrigger: trigger; (* trigger to find 'default' *)
   nametrigger: trigger; (* trigger to find 'name' *)
   piecetrigger: trigger; (* trigger to find 'piece' *)
   settrigger: trigger; (* trigger to find 'set' *)

   begincomment: trigger; (* trigger to find '(-*' (ignore the dash!) *)
   endcomment: trigger; (* trigger to find '*-)'  (ignore the dash!) *)
   begincurly: trigger; (* trigger to find comments: '{' *)
   endcurly: trigger; (* trigger to find comments: '}' *)

   quote1trigger: trigger; (* trigger to find single quote ' *)
   quote2trigger: trigger; (* trigger to find double quote " *)

   dotteddone: boolean; (* a dot '.' has been found in the name - ignore
      the rest of the name - for comparisons with mutations. *)

{
procedure rd(var f: text; var ch: char);
(* read ch from f allowing inspection of the result *)
begin
   read(f,ch);
   write(output,ch);
   write(list,ch);
   write(output,'<',ch,'>');
end;

procedure rdln(var f: text);
(* readln f allowing inspection of the result *)
begin
   readln(f);
   writeln(output);
   writeln(list);
end;
}

procedure skipcomment(var f: text);
(* skip an entire comment *)
var
   comment: boolean; (* true means we are inside a comment *)
begin
   (* skip to end of comment *)
   resettrigger(endcomment);
   comment := true;
   while comment do begin
      if eof(f) then begin
         writeln(output,'A comment does not end!');
         halt
      end;
      if eoln(f) 
      then readln(f)
{ rdln(f) }
      else begin
{write(output,'<');
rd(f,ch);
write(output,'>');}
         read(f,ch);
         testfortrigger(ch, endcomment);
         if endcomment.found
         then comment := false;
      end
   end
end;

procedure skipcurly(var f: text);
(* skip an entire comment made by {}*)
var
   comment: boolean; (* true means we are inside a comment *)
begin
   (* skip to end of comment *)
   resettrigger(endcurly);
   comment := true;
   while comment do begin
      if eof(f) then begin
         writeln(output,'A comment does not end!');
         halt
      end;
      if eoln(f) 
      then readln(f)
{ rdln(f) }
      else begin
{write(output,'<');
rd(f,ch);
write(output,'>');}
         read(f,ch);
         testfortrigger(ch, endcurly);
         if endcurly.found
         then comment := false;
      end
   end
end;

procedure skipquote(quote: trigger);
(* skip an entire quote of either the ' or " persuasion *)
var
   kind: char; (* the kind of quote, ' or " *)
begin
   kind := quote.seek.letters[1];
{writeln(output,'skipquote ',kind);}
   repeat
      findnonblank(inst,ch); (* get to the quote *)
   until (ch = kind) or eof(inst);
   if ch <> kind then begin
      writeln(output,'end of quote starting with ',kind,' not found');
      halt;
   end;
end;

begin
 filltrigger(defaulttrigger,'default');
     filltrigger(gettrigger,'get    ');
    filltrigger(nametrigger,'name   ');
   filltrigger(piecetrigger,'piece  ');
     filltrigger(settrigger,'set    ');
   filltrigger(begincomment,'(*     ');
     filltrigger(endcomment,'*)     ');
     filltrigger(begincurly,'{      ');
       filltrigger(endcurly,'}      ');
  filltrigger(quote1trigger,'''      ');
  filltrigger(quote2trigger,'"      ');

  resettrigger(defaulttrigger);
  resettrigger(gettrigger);
  resettrigger(nametrigger);
  resettrigger(piecetrigger);
  resettrigger(settrigger);

  resettrigger(begincomment);
  resettrigger(begincurly);
  resettrigger(quote1trigger);
  resettrigger(quote2trigger);

   indefault := false;

   if not eof(book) then begin (* if there is still more to the book ... *)
      getpiece(book,theline,pie); (* read in the piece *)
      if not eof(book) then begin (* if we found a piece ... *)
         length:=pietoint(pie^.key.pieend,pie); (* calculate piece length *)

         (* now find in inst the next occurance of 'get' *)
         done := false;
         while not done do begin
            if eof(inst) then begin (* no instructions? *)
               alignedbase := 1; (* simply align by the first base *)
               done := true
            end
            else begin
               if eoln(inst)
               then readln(inst)
{then rdln(inst)}
               else begin
{rd(inst,ch);}
                  read(inst,ch);

                  testfortrigger(ch, begincomment);
                  testfortrigger(ch, begincurly);
                  if begincomment.found or begincurly.found
                  then begin
                     if ch = '*' then begin
                        skipcomment(inst);
                        resettrigger(begincomment);
                     end
                     else begin
                        resettrigger(begincurly);
                        skipcurly(inst);
                     end
                  end
                  else begin (* we are not inside a comment *)

                     testfortrigger(ch, gettrigger);
                     if gettrigger.found then begin
                        findnonblank(inst,ch); (* get to "from" *)
                        findblank(inst); (* get past "from" *)
                        read(inst,thebase); (* read in the alignedbase *)
{writeln(output);writeln(output,'thebase = ',thebase:1);}
                        alignedbase:=pietoint(thebase,pie);
{writeln(output,'alignedbase=',alignedbase:1);}
                        done := true
                     end;

                     testfortrigger(ch, quote1trigger);
                     if quote1trigger.found then begin
                        skipquote(quote1trigger);
                     end;

                     testfortrigger(ch, quote2trigger);
                     if quote2trigger.found then begin
                        skipquote(quote2trigger);
                     end;

                     testfortrigger(ch, defaulttrigger);
                     if defaulttrigger.found then begin
                        indefault := true;
                        resettrigger(defaulttrigger)
                     end;
                     if ch = semicolon then indefault := false;

                     testfortrigger(ch, settrigger);
                     if settrigger.found then begin
                        indefault := true;
                        resettrigger(settrigger)
                     end;
                     if ch = semicolon then indefault := false;

                     (* check that piece names are correct *)
                     testfortrigger(ch, piecetrigger);
                     if not indefault then if piecetrigger.found then begin
                        skipblanks(inst); (* get to name *)
                        with pie^.key.hea.keynam do begin
{
                           for p := 1 to length do begin
}
                           (* 2007 Jun 22: replace loop with while
                              so that we can drop out when dotted
                              names are detected. *)
                           p := 1;
                           dotteddone := false;
                           while not dotteddone do begin
                              if eoln(inst)
                              then dotteddone := true
                              else begin
                                 read(inst,ch);
                                 (* ignore names after a dot *)
{
if ch = '.' then writeln(output,'inst dotteddone');
}
                                 if ch         = '.' then dotteddone := true;
                                 if letters[p] = '.' then dotteddone := true;
{
if ch = '.' then writeln(output,'book dotteddone');
writeln(output,'BUBBa ch = ',ch,'     ',p:1);
}
{zzz}
                                 if (letters[p] <> ch) and (not dotteddone) and
                                    (ch <> ';')
                                 then begin
                                    writeln(output,
                                           'The piece name in the book: ');
                                    writeln(output,letters:length);
                                    writeln(output,'does not match',
                                                 ' the inst file piece name:');
                                    (* write the letters that matched: *)
                                    for p1 := 1 to p-1 
                                        do write(output,letters[p1]);
                                    (* write the offending letter: *)
                                    write(output, ch);
                                    (* get the rest of the name and show it: *)
                                    done := eoln(inst);
                                    while not done do begin
                                      done := eoln(inst);
                                      if not done then begin
                                        read(inst,ch); 
                                        if (ch = ' ') or (ch = ';') 
                                        then done := true;
                                        if not done then write(output,ch);
                                      end; 
                                    end;
                                    writeln(output);
                                    (* mark the first letter
                                       that does not match: *)
                                    for p1 := 1 to p-1 do write(output,' ');
                                    write(output,'^'); 
                                    writeln(output);
                                    halt
                                 end;
                                 p := p + 1;
                                 if p > length then dotteddone := true;
                              end;
                           end
                        end;
                     end;

                  end
               end
            end
         end;

         if (alignedbase <= -maximumrange) or
            (alignedbase > length + maximumrange) then begin
            writeln(output,' In procedure align:');
            writeln(output,' read in base was ',thebase:1);
            writeln(output,' in internal coordinates: ',alignedbase:1);
            writeln(output,' maximum range was ',maximumrange:1);
            writeln(output,' piece length was ',length:1);
            with pie^.key.hea.keynam
               do writeln(output,' piece name: ',letters:length);
            writeln(output,' piece number: ',number:1);
            writeln(output,' aligned base is too far away... see the code');
            halt
         end
      end
   end
end;
(* end module align.align version = 7.74; {of delmod.p 2013 Jan 17} *)

(* ************************************************************************ *)
(* end module package.align version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module align.maxminalignment *)
procedure maxminalignment(var inst, book: text; var theline: integer;
                          var fromparam, toparam: integer;
                          alignmenttype: char);
(* prescan the book to find the range over which the pieces of the
   book are spread, relative to the aligned base.  the procedure uses
   the same variables that align does (so it can call align itself), and
   it returns the range in fromparam and toparam.
   alignmenttype: 'f' means alignment by First internal coordinate
      base, 'b' means alignment by Book, 'i' means alignment by Instructions.
 *)
const
      maximumrange = 10000; (* the maximum size aligned piece;
                             this will presumably catch the alignment bug *)
var
      distance: integer; (* a distance to the aligned base *)
      pie:  pieceptr;
      length, alignedbase: integer;
begin
      new(pie);
      (* set an initial range for the two bounds *)
      fromparam:=+maxint;
        toparam:=-maxint;

      reset(book);
      reset(inst);
      while not eof(book) do begin
         case alignmenttype of
            'i': align(inst,book,theline,pie,length,alignedbase);
            'b','f':  begin
                 getpiece(book,theline,pie); (* read in the piece *)
                 length := piecelength(pie);
            end;
         end;

         if not eof(book) then begin
            case alignmenttype of
               'f': begin (* force alignment on first base *)
                    alignedbase := 0;
                    fromparam := 1;
                    distance:=length-alignedbase;
                    if toparam < distance then toparam:=distance;
               end;
               'i': begin (* use the alignedbase from the book *)
                    distance:=1-alignedbase;
                    if fromparam > distance then fromparam:=distance;

                    distance:=length-alignedbase;
                    if toparam < distance then toparam:=distance;
               end;
               'b': begin (* use the internal book *)
                    alignedbase := pietoint(0, pie);
                    distance:=1-alignedbase;
                    if fromparam > distance then fromparam:=distance;

                    distance:=length-alignedbase;
                    if toparam < distance then toparam:=distance;
               end;
            end;

            clearpiece(pie)
         end
      end;

      if toparam - fromparam > maximumrange then begin
         writeln(output,' in procedure maxminalignment:');
         writeln(output,' alignedbase = ',alignedbase:1);
         writeln(output,' fromparameter = ',fromparam:1);
         writeln(output,' toparameter = ',toparam:1);
         writeln(output,' this exceeds the maximum range allowed (',
                        maximumrange:1,')');
         writeln(output,' see notes in the procedure. ');
         halt
         (* notes:  if you desired this range, increase 'maximumrange'.
            otherwise, this may indicate a bug - either:
            1) locate the bug (and tell tom schneider, please...)
            2) reduce the size of the fragments, from one or the other end
               until the bombing is stopped. *)
      end;

      (* make the book readable again *)
      reset(book);
      reset(inst);
      dispose(pie)
end;
(* end module align.maxminalignment version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module align.withinalignment *)
function withinalignment(alignedposition, alignedbase, length: integer)
                         :boolean;
(* this function tells one if an aligned position, relative to an aligned
   base in a piece of some length is within the piece. *)
var   p: integer;(* the position on the piece *)
begin
      p := alignedposition + alignedbase;
      withinalignment := (p>0) and (p<=length)
end;
(* end module align.withinalignment version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.getbase *)
function getbase(position: integer; pie: pieceptr):base;
(* Get a base from the position (internal coordinates) of the
   piece.  Protection is made against positions outside the piece.
In the case of circles it would be convenient to wrap around when
requests are off the end.  So the routine will do a modular
wrap for positions outside the range 1 to the length.
This is a new feature as of 2000 March 22.
*)
var
   workdna: dnaptr; (* pointer to the dna part of pie *)
   p: integer; (* current count of bases into the workdna *)
   spot: integer; (* the last base of the dna part *)
   thelength: integer; (* the length of the piece *)
begin
{
writeln(output,'NEW getbase: position=',position:1,'^^^^^^^^^^^^^^^^^^^^');
}
   (* handle cases of position out of range by circular wrapping *)
   thelength := piecelength(pie);
   while position < 1         do position := position + thelength;
   while position > thelength do position := position - thelength;

   workdna:=pie^.dna;
   p:=workdna^.length;
   while position > p do begin
{
writeln(output,' workdna^.length=',workdna^.length:1);
}
      workdna := workdna^.next;
      if workdna = nil then begin
        writeln(output,'error in function getbase!');
        halt
      end;
      p := p + workdna^.length;
   end;
{
writeln(output,'p=',p:1);
}
   if workdna = nil then begin
      writeln(output,'error in getbase: request off end of piece');
      halt
   end
   else begin
      spot := workdna^.length - (p-position);
{
writeln(output,'spot=',spot:1);
showdnasegment(output,workdna, spot);
}
      if (spot <= 0) then begin
         writeln(output,'error in getbase, spot (= ',spot:1, ') must be positive');
         halt
      end;
      if (spot > workdna^.length) then begin
         writeln(output,'error in getbase, spot (=',spot:1,
                        ') must be less than length (=',workdna^.length:1,')');
         halt
      end;
{
writeln(output,'base = ', workdna^.part[spot]);
}
      getbase:=workdna^.part[spot]
   end
end;
(* end module book.getbase version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module package.numbar *)
(* ************************************************************************ *)
(* begin module numberdigit *)
function numberdigit(number, logplace:integer): char;
(* return the digit at the place value ('logplace') position of number.
example:
      numberdigit(13625, 3) = 3
      numberdigit(13625, 4) = 1
2000 July 30 'myabsolute' replaced 'absolute', which
is apparently a keyword for GPC.  The name is kept
to keep the code looking similar to its origin.
*)
var
      place: integer; (* the exponent of logplace *)
      count: integer; (* used to make place *)
      myabsolute: integer; (* the absolute value of number *)
      acharacter: char; (* the character to be returned *)
procedure digit;
(* extract a digit at the place position *)
var
      tenplace: integer; (* ten times place *)
      z: integer; (* an intermediate value *)
      d: integer; (* the digit extracted *)
begin (* digit *)
      tenplace:=10*place;
      z:=myabsolute-((myabsolute div tenplace)*tenplace);
      if place = 1
         then d:=z
         else d:= z div place;
      case d of
         0: acharacter:='0';
         1: acharacter:='1';
         2: acharacter:='2';
         3: acharacter:='3';
         4: acharacter:='4';
         5: acharacter:='5';
         6: acharacter:='6';
         7: acharacter:='7';
         8: acharacter:='8';
         9: acharacter:='9';
      end
end; (* digit *)
procedure sign;
(* put a negative sign out or a positive sign *)
begin (* sign *)
      if number <0 then acharacter:='-'
                   else acharacter:='+'
end; (* sign *)
begin (* numberdigit *)
      place:=1;
      for count:=1 to logplace do place:=10*place;

      if number=0 then begin
         if place=1 then acharacter:='0'
                    else acharacter:=' '
      end
      else begin
         myabsolute:=abs(number);
         if myabsolute < (place div 10)
            then acharacter:=' '
            else if myabsolute >= place
                    then digit
                    else sign
      end;
      numberdigit:=acharacter
end; (* numberdigit *)
(* end module numberdigit version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module numbersize *)
function numbersize(n: integer):integer;
(* calculate amount of space to be reserved for the integer n *)
const ln10 = 2.30259; (* natural log of 10 - for conversion to log base 10 *)
      epsilon = 0.00001; (* a small number to correct log base 10 errors *)
var
   size: integer; (* intermediate result *)
begin (* numbersize *)
   if n = 0
   then numbersize:=1
   else begin
      size:=trunc(ln(abs(n))/ln10 + epsilon) + 1;
      (* the 1 is for the last digit *)
      (* the epsilon assures that we do not lose a place due to
         roundoff.  eg, sometimes log base 10 of 10 would be 0.9999
         instead of 1, and we would not do it right...  note: this will
         fail for very large numbers on the order of 1/epsilon. *)
      if n < 0 then size := succ(size);  (* account for minus sign *)
      numbersize := size;
   end
end; (* numbersize *)
(* end module numbersize version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module numberbar *)
function firstlastmax(firstnumber, lastnumber: integer): integer;
(* compute the sizes of firstnumber and lastnumber (including + or -
sign) and then determine which number is larger *)
var
   firstlines: integer; (* number of lines needed for firstumber *)
   lastlines: integer; (* number of lines needed for lastnumber *)
begin
   firstlines := numbersize(firstnumber);
   if firstnumber > 0
   then firstlines := firstlines + 1; (* add one more for + sign *)
   lastlines := numbersize(lastnumber);
   if lastnumber > 0
   then lastlines := lastlines + 1; (* add one more for + sign *)
   if firstlines > lastlines
   then firstlastmax := firstlines
   else firstlastmax := lastlines;
end;

procedure numberbar(var afile: text; spaces, firstnumber, lastnumber: integer;
                    var linesused: integer);
(* write a bar of numbers to a file, with several spaces before.
   the number of lines used is returned *)
var
   logplace: integer; (* the log of the digit being looked at *)
   number: integer; (* the current number being written *)
   spacecount: integer; (* count of spaces *)
begin
{ 2000 June 24:  This code was not sufficient to deal with the sign
correctly.  The numbersize routine now does *not* give the + sign
(which makes it useful for other purposes) so we have to account
for it here now.
   if abs(firstnumber) > abs(lastnumber)
      then linesused:= numbersize(firstnumber)
      else linesused:= numbersize(lastnumber);
}
   linesused := firstlastmax(firstnumber, lastnumber);
{
writeln(output,'numberbar says linesused = ',linesused:1);
      for logplace:=linesused-1 downto 0 do begin
1999 July 15: this is changed to linesused since numbersize now
accounts for the sign:
   for logplace := linesused downto 0 do begin
2000 June 24:  back to the old code ...
}
   for logplace := linesused-1 downto 0 do begin
      for spacecount:=1 to spaces do write(afile,' ');
      for number:=firstnumber to lastnumber
         do write(afile,numberdigit(number,logplace));
      writeln(afile)
   end
end;
(* end module numberbar version = 5.27; (@ of prgmod.p 2005 Aug 06 *)
(* ************************************************************************ *)
(* end module package.numbar version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module align.getpositions *)
procedure getpositions(var inst, book: text;
                       var positionwidth, numberwidth: integer;
                       var count: integer; (* number of pieces found *)
                       alignmenttype: char);
(* prescan the book to find the width of position numbers and
the number of fragments.  Convert these to the minimum widths necessary
to print them.
NOTE: although one can count the number of pieces, this is not
necessarily the number to use for numberwidth!  The reason is that
numbers are controlled by Delila.  So one wants the max of the global
'number'. *)
var
   abmin: integer; (* minimum of the aligned base coordinates *)
   abmax: integer; (* maximum of the aligned base coordinates *)
   coordinate: integer; (* an alignment coordinate *)
   maxnumber: integer; (* maximum of global 'number' *)
   negatives: boolean; (* the maximum number was negative *)
   pie:  pieceptr; (* a piece of DNA *)
   length, alignedbase: integer; (* the length of the pie and its aligned base *)
begin
   new(pie);
   brinit(book,theline);
   reset(inst);

   abmin := 0;
   abmax := 0;
   count := 0;
   maxnumber := 0;
   negatives := false;
   while not eof(book) do begin
      case alignmenttype of
         'i': align(inst,book,theline,pie,length,alignedbase);
         'b','f':  getpiece(book,theline,pie); (* read in the piece *)
      end;

      if not eof(book) then begin
         count := count + 1;
         if abs(number) > maxnumber then begin
            maxnumber := abs(number);
            if number < 0 then negatives := true
                          else negatives := false
         end;

         case alignmenttype of
            'f': coordinate := inttopie(1,pie);
            'b','i': coordinate := inttopie(alignedbase,pie);
         end;
         if abs(coordinate) > abs(abmax) then abmax := coordinate;
         if    (coordinate) <    (abmin) then abmin := coordinate;

         clearpiece(pie)
      end
   end;

   (* make the book readable again *)
   reset(book);
   reset(inst);
   dispose(pie);

   (* Finally, determine the number of characters necessary for printing the
      number.  Numbersize allows for a sign.  A Delila instruction
      could give negative numbers to a piece.  Otherwise, we remove the extra
      blank with the if statement below.  *)
   numberwidth := numbersize(maxnumber);

(*
writeln(output,'count=',count:1);
writeln(output,'numberwidth=',numberwidth:1);
*)
   if (abmin = 0) and (abmax = 0)
   then positionwidth := 1
   else begin
     {positionwidth := numbersize(ab);}
     if numbersize(abmax) > numbersize(abmin)
     then positionwidth := numbersize(abmax)
     else positionwidth := numbersize(abmin)
   end;

{
writeln(output,'abmin        =',abmin        :1,'===========');
writeln(output,'abmax        =',abmax        :1,'===========');
writeln(output,'positionwidth=',positionwidth:1,'===========');
}

end;
(* end module align.getpositions *)

procedure noheader(var a: text);
begin
   writeln(a,' % NOHEADER FOR PACKAGING INTO ANOTHER FIGURE');
end;

procedure removeit(var a: text);
begin
   writeln(a,' % REMOVE FOR PACKAGING INTO ANOTHER FIGURE');
end;

(* begin module pnumberbar *)
procedure pnumberbar(var afile: text; spaces, firstnumber, lastnumber: integer;
                     var linesused: integer);
(* write a bar of numbers to a file, with several spaces before.
The number of lines used is returned.
In this variant of numberbar lines are to be written in postscript.
By doing things this way, upgrades to numberbar automatically get
are applied to this routine.  (I got caught on one upgrade that
did not propagate to this routine!) *)
var
   internal: text; (* internal file for creating the result *)
begin
   rewrite(internal);
   numberbar(internal, spaces, firstnumber, lastnumber, linesused);
   reset(internal);
   while not eof(internal) do begin
      write(afile,'(');
      while not eoln(internal) do begin
         afile^ := internal^;
         put(afile);
         get(internal)
      end;
      readln(internal);
      writeln(afile,') sn');
   end;
end;
(* end module pnumberbar *)

(* begin module book.name *)
procedure clearname(var n: name);
(* clear the name n *)
var
  i: integer; (* index to piece name *)
begin
  n.length := 0;
  for i := 1 to namelength do n.letters[i] := ' ';
end;

procedure writename(var f: text; n: name);
(* write the name n to file f *)
var
  i: integer; (* index to piece name *)
begin
   for i := 1 to n.length do
       write(f,n.letters[i]);
end;

procedure copyname(a: name; var b: name);
(* copy name a to name b *)
var
  i: integer; (* index to piece name *)
begin
   for i := 1 to a.length
   do b.letters[i] := a.letters[i];
   b.length := a.length;
end;

function equalname(a,b: name): boolean;
(* is name a equal to name b? *)
var
  i: integer; (* index to piece name *)
  same: boolean; (* temporary variable to hold the answer *)
begin
   same := true; (* what optimism!! *)
   if b.length = a.length
   then begin
      i := 1;
      while same and (i <= a.length) do begin
         same := (b.letters[i] = a.letters[i]);
         i := succ(i);
      end
   end
   else same := false;
   equalname := same;
end;
(* end module book.name version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brorgkey *)
procedure brorgkey(var thefile: text; var theline: integer; var org: orgkey);
(* read organism key *)
begin
      with org do begin
{bbb}
         brheader(thefile,theline,hea);
         getline(mapunit);
         brline(thefile,theline,mapunit);
      end
end;
(* end module book.brorgkey version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.brchrkey *)
procedure brchrkey(var thefile: text; var theline: integer; var chr: chrkey);
(* read chromosome key *)
begin
      with chr do begin
{bbb}
         brheader(thefile,theline,hea);
         brreanum(thefile,theline,mapbeg);
         brreanum(thefile,theline,mapend);
      end
end;
(* end module book.brchrkey version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module book.getocp *)
procedure getocp(var thefile: text; var theline: integer;
                 var org: orgkey;   var orgchange, orgopen: boolean;
                 var chr: chrkey;   var chrchange, chropen: boolean;
                 var pie: pieceptr; var piechange, pieopen: boolean);
(* Get the next piece and its organism and chromosome keys.  The three change
variables indicate whether or not a new organism, chromosome or piece name
was found.  If a piece is not found, then pieopen will be false.  orgopen,
chropen and pieopen are used by getocp to tell when it has entered an
organism, chromosome or piece.  All booleans should be set to false
initially.  There should be one triplet for each book read.

It is important to initialize ALL variables, including pie:

   orgchange := false; orgopen := false;
   chrchange := false; chropen := false;
   piechange := false; pieopen := false;
   pie := nil;
   theline := 0;

1999 June 2  The book reading routines now treat data objects more
precisely.  Rather than test for eof, the endo of book occurs when pieopen is
returned as false.  A book reading loop now looks like this:

   repeat
      getocp(book, theline,
                   org, orgchange, orgopen,
                   chr, chrchange, chropen,
                   pie, piechange, pieopen);
      writeln(output,'pieopen: ',pieopen);
      if pieopen then begin
         writeln(output,'piece at line: ',theline:1);
      end;
   until not pieopen;
*)

var
      ch: char;
      newchr: chrkey;
      neworg: orgkey;
      newpie: pieceptr;
begin
      ch:='a';
      while not (ch in [' ','p']) do begin
         ch:=getto(thefile,theline,['o','c','p']);
         if ch <> ' ' then begin
            case ch of
               'o': if orgopen
                  then begin
                     readln(thefile);
                     (* move past the word 'organism'
                        - new definition 1999 Mar 13 *)
                     orgopen:=false (* close organism *)
                  end
                  else begin
                     brorgkey(thefile,theline,neworg);
                     if (neworg.hea.keynam.letters <> org.hea.keynam.letters) and
                        (neworg.hea.keynam.length <> org.hea.keynam.length)
                     then begin
{
writeln(output,'--------orgchanged!');
write  (output,'--------old org:"',   org.hea.keynam.letters);
writeln(output,              '" ',    org.hea.keynam.length:1);
write  (output,'--------new org:"',neworg.hea.keynam.letters);
writeln(output,              '" ',neworg.hea.keynam.length:1);
}
(*ccc*)
                        orgchange:=true;
                        copyheader(neworg.hea,org.hea);
                        (* move the mapunit over to the org! *)
                        org.mapunit := neworg.mapunit;
                        clearline(neworg.mapunit);

                     end
                     else orgchange:=false;
                     orgopen:=true;
                  end;
               'c': if chropen
                  then begin
                     readln(thefile);
                     (* move past the word 'chromosome'
                        - new definition 1999 Mar 13 *)
                     chropen:=false (* close chromosome *)
                  end
                  else begin
                     brchrkey(thefile,theline,newchr);
                     if (newchr.hea.keynam.letters <> chr.hea.keynam.letters) and
                        (newchr.hea.keynam.length <> chr.hea.keynam.length)
                     then begin
{
writeln(output,'--------chrchanged!');
write  (output,'--------old chr:"',   chr.hea.keynam.letters);
writeln(output,              '" ',    chr.hea.keynam.length:1);
write  (output,'--------new chr:"',newchr.hea.keynam.letters);
writeln(output,              '" ',newchr.hea.keynam.length:1);
}
                        chrchange:=true;
                        copyheader(newchr.hea,chr.hea);
                        (* move the map range over to the chr! *)
                        chr.mapbeg := newchr.mapbeg;
                        chr.mapend := newchr.mapend;
                     end
                     else chrchange:=false;
                     chropen:=true;
                  end;
               'p': if pieopen
                  then begin
                     pieopen:=false; (* close last piece *)
                     ch:='a' (* prevent falling out of the loop *)
                  end
                  else begin
                     new(newpie);
                     brpiece(thefile,theline,newpie);
                     if pie = nil
                     then piechange := true
                     else begin
                        if (newpie^.key.hea.keynam.letters
                         <> pie^.key.hea.keynam.letters) and
                           (newpie^.key.hea.keynam.length
                         <> pie^.key.hea.keynam.length)
                        then begin
                           piechange:=true;
                        end
                        else piechange:=false;
                     end;
                     pieopen:=true;
                     (* we always have to switch over to the new piece,
                        because although the name may be the same,
                        the DNA sequence could be different.  That is,
                        the book may contain two pieces with the same
                        name, and we want to be sure to search the
                        new one, not the old one. *)
                     if pie <> nil then begin
                        clearpiece(pie); (* save the links *)
                        dispose(pie); (* close up shop *)
                     end;
                     pie := newpie;
                  end
            end
         end
         else begin
            pieopen := false
         end
      end
end;
(* origin: search version = 6.39 *)
(* end module book.getocp version = 7.74; {of delmod.p 2013 Jan 17} *)

(* begin module emptyfile *)
function emptyfile(var afile: text): boolean;
(* This function is a replacement for eof() to get around a bug in the
GPC compiler.  The GPC bug is that end-of-file, as provided by eof(),
is false when a file is empty.  The way to get around it is to count
characters in the file to determine if it is empty.  Fortunately this
is fast for large files because the count stops once a single or a few
characters are seen.  A single character will not do unfortunately
because GPC will give an '*' for an empty file.  So the test is for
having a certain number (boundary) or fewer characters.  This is not
great, but it only means that the file must be at least 'boundary'
characters long.  Furthermore, since the file is being READ, the
emptyfile test CANNOT be used in a loop to test for eof!  Use
emptyfile only to check that the file is empty.  Use eof inside loops
IF the file is not empty.
  Dr. Thomas D. Schneider
  toms@alum.mit.edu
  permanent email: toms@alum.mit.edu (use only if first address fails)
  https://alum.mit.edu/www/toms/
*)
const
   debugging = false;
   boundary = 2; (* one needs at least this many characters for
     a file to be considered 'non empty'. *)
var
   lines: integer; (* count of lines in the file *)
   chars: integer; (* count of characters in the file *)
   ch: char; (* a character in the file *)
begin
   reset(afile);
   lines := 0;
   chars := 0;
   while (not eof(afile)) and (chars < boundary) do begin
      if eoln(afile) then begin
         lines := succ(lines);
         readln(afile);
      end
      else begin
         read(afile,ch);
         if debugging then begin
            writeln(output,'ord(ch) = ',ord(ch));
            writeln(output,'    ch  = ',    ch );
         end;
         chars := succ(chars);
      end
   end;
   if chars < boundary
   then emptyfile := true
   else emptyfile := false;
   if debugging then begin
      writeln(output,'lines = ',lines:1);
      writeln(output,'chars = ',chars:1);
      if chars < boundary
      then writeln(output,'    empty (file)')
      else writeln(output,'NOT empty (file)');
   end;
   reset(afile); (* put the file back at the start!! *)
end;
(* end module emptyfile *)

(* begin module getname *)
procedure getname(var namebook: text; theline: integer;
                      nametype: char;
                  var typefound: char;
                  var aname: name;
                  var org: orgkey;   var orgchange, orgopen: boolean;
                  var chr: chrkey;   var chrchange, chropen: boolean;
                  var pie: pieceptr; var piechange, pieopen: boolean);
(* get to the next name in name book, looking for an organism
or the type defined by nametype.  org/chr/pie and the change and open
booleans keep track of where we are in the book.  They are used
by getocp. *)
(* getname should eventually be replaced by a procedure that
reads instructions rather than a book. ... 2000 May 9 probably not.
*)
begin
{
writeln(output,'getname: searching for nametype=',nametype);
}

   if eof(namebook)
   then typefound:=' '
   else begin
      typefound:='.';
      repeat
         getocp(book, theline,
                      org, orgchange, orgopen,
                      chr, chrchange, chropen,
                      pie, piechange, pieopen);
         if pieopen then begin
            typefound := 'p';
            aname := pie^.key.hea.keynam;
         end
         else if chropen then begin
            typefound := 'c';
            aname := chr.hea.keynam;
         end
         else if orgopen then begin
            typefound := 'o';
            aname := org.hea.keynam;
         end
         else begin
            typefound := ' ';
         end
      until typefound in [' ', 'o', nametype];
   end
{
;writeln(output,'getname: typefound = "',typefound,'"');
;write(output,'getname: obtained: "');
;writename(output,aname);
;writeln(output,'" -----------------------');
;writeln(output);
}
end;
(* end module getname *)

(* begin module maxname *)
procedure maxname(var namebook: text; theline: integer;
                      nametype: char;
                  var namewidth: integer;
                  var tofile: text;
                  var linenumber: integer;
                  var org: orgkey;   var orgchange, orgopen: boolean;
                  var chr: chrkey;   var chrchange, chropen: boolean;
                  var pie: pieceptr; var piechange, pieopen: boolean);
(* figure out the maximum length needed to be allocated
to print the names, print book information in tofile, and
increment linenumber of tofile *)
var
   aname: name; (* a name *)
   typefound: char; (* what thing was found *)
begin
   reset(namebook);
   namewidth := 0;
   if not emptyfile(namebook) then begin
      brinit(namebook, theline);
      orgchange := false; chrchange := false; piechange := false;
      orgopen   := false; chropen   := false; pieopen   := false;
      if headercontrol = 'h' then begin
         case nametype of
            'g': write(tofile, 'gene');
            't': write(tofile, 'transcript');
            'p': write(tofile, 'piece');
         end;
         writeln(tofile, ' names from:');
         splitbooktitle(namebook, tofile);
         theline := theline + 1;
         linenumber := linenumber + 2;
      end;
      typefound:='.';
      orgopen:=false;
      while typefound <> ' ' do begin
         getname(namebook, theline, nametype, typefound, aname,
                 org, orgchange, orgopen,
                 chr, chrchange, chropen,
                 pie, piechange, pieopen);
         if not(typefound in ['o', ' '])
         then (* is g t or p *)
            if typefound = nametype
            then if aname.length > namewidth
            then namewidth:=aname.length
      end
   end;
end;
(* end module maxname *)

(* begin module maxfullnamewidth *)
procedure maxfullnamewidth(var book: text; theline: integer;
                  var fullnamewidth: integer);
(* figure out the maximum length needed to be allocated
to print long names *)
var
   fullname: lineptr; (* line containing fullname *)
   typefound: char; (* what thing was found *)
begin
   reset(book);
   fullnamewidth:=0;
{writeln(output,'maxfullnamewidth');}

   while not eof(book) do begin
{writeln(output,'@',book^);}
      typefound := getto(book,theline,['p']);
      if typefound = 'p' then begin
         readln(book); (* skip name *)
         readln(book); (* get full name *)
         getline(fullname);
         brline(book,theline,fullname);
{
write(output,'maxfullnamewidth name: "');
for index := 1 to fullname^.length
do write(output, fullname^.letters[index]);
writeln(output,'"');
}

         if fullname^.length > fullnamewidth
         then fullnamewidth:=fullname^.length;
{
writeln(output,'fullnamewidth:', fullnamewidth:1);
}
         clearline(fullname);

         (* locate end of piece *)
         typefound := getto(book,theline,['p']);
         if typefound <> 'p' then begin
            writeln(output,'book structure is bad:', 
                           ' a piece does not have an end');
            halt;
         end;
         readln(book);
         theline := succ(theline);
      end
   end;
{
writeln(output,'ending fullnamewidth:', fullnamewidth:1);
}

{uuu BUBBA}
{
writeln(output, '************** fullnamewidth = ', fullnamewidth:5,' ******');
}

end;
(* end module maxfullnamewidth *)

(* begin module printname *)
procedure printname(var namebook: text; theline: integer;
                        nametype: char;
                        namewidth: integer;
                    var tofile, ctofile: text;
                    var org: orgkey;   var orgchange, orgopen: boolean;
                    var chr: chrkey;   var chrchange, chropen: boolean;
                    var pie: pieceptr; var piechange, pieopen: boolean;
                    var linenumber, clinenumber: integer);
(* print names of items in the book from namebook to tofile.
   organism is always printed, and one other type specified by nametype
   (one of 'g', 't', 'p') is printed namewidth wide.
   orgopen is used to keep track of the organism. *)
var
      aname: name; (* the name found *)
      typefound: char; (* the type of the name *)
      index: integer; (* for printing the name *)
begin
      repeat
         getname(namebook, theline, nametype, typefound, aname,
                 org, orgchange, orgopen,
                 chr, chrchange, chropen,
                 pie, piechange, pieopen);
         if typefound <> ' ' then begin
            case typefound of
               'o': begin
                  writeln(tofile);
                  writeln(tofile, ' organism ', aname.letters);
                  writeln(ctofile);
                  writeln(ctofile, ' organism ', aname.letters);
                  linenumber:=linenumber+2; (* two lines written *)
                  clinenumber:=clinenumber+2 (* two lines written *)
               end;
               'g', 't', 'p': begin
                  write(tofile, ' ');
                  write(ctofile, ' ');
                  for index:=1 to namewidth
                     do write(tofile, aname.letters[index]);
                  for index:=1 to namewidth
                     do write(ctofile, aname.letters[index])
               end
            end
         end
      until typefound in [' ', nametype]
end;
(* end module printname *)

(* begin module maxnamelist *)
procedure maxnamelist(var namelist: text; var namelistwidth: integer);
(* determine the length of the longest line in namelist. *)
var
   c: char; (* a character for reading namelist *)
   currentmax: integer; (* the current maximum *)
   count: integer; (* count of characters in the file.  This is
      to get around a problem in GPC: GPC does not give file EOF
      when the file has been reset! *)
begin
   reset(namelist);
   count := 0;
   if not emptyfile(namelist) then begin
      currentmax := 1; (* allow 1 space at the start *)
      while not eof(namelist) do begin
         if eoln(namelist)
         then begin
            readln(namelist);
            if currentmax > namelistwidth then namelistwidth := currentmax;
            currentmax := 1; (* allow 1 space at the start *)
         end
         else begin
            read(namelist, c);
            count := count + 1;
            currentmax := succ(currentmax);
         end;
      end;
   end
   else namelistwidth := 0;
(*
writeln(output,' namelistwidth = ',namelistwidth:1);
writeln(output,' count = ',count:1);
*)
end;
(* end module maxnamelist *)

(* begin module makelogo.protectcharacter *)
procedure protectcharacter(c: char;
                       var protectioncharacter: char;
                       var needed: boolean);
(* In PostScript, special characters must be protected against.
This routine looks at a character c and returns a protection character
if it is needed.
The parenthesis is used in PostScript to indicate the bounds of a
string, while the percent is the comment character.  The backslash also needs
protection, since it is the escape to indicate that the next character is part
of the string. *)
begin
   if c in ['(',')','%','\']
   then begin
      protectioncharacter := '\';
      needed := true
   end
   else begin
      protectioncharacter := ' ';
      needed := false
   end
end;
(* end module makelogo.protectcharacter version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module makelogo.protectpostscript *)
procedure protectpostscript(var afile: text; c: char);
(* Special characters must be protected against!  Put out a protective
backslash for character c which would otherwise destroy the PostScript
interpreter.  The parenthesis is used in PostScript to indicate the bounds of a
string, while the percent is the comment character.  The backslash also needs
protection, since it is the escape to indicate that the next character is part
of the string. *)
var
   needed: boolean; (* is protection needed? *)
   protectionchar: char; (* is protection needed? *)
begin
   protectcharacter(c, protectionchar, needed);
   if needed then write(afile,protectionchar);
end;
(* end module makelogo.protectpostscript version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

procedure figureblanks(var blanks: integer);
(* figure out how many blanks to use in the display for numberbar *)
begin
      (* the blank before the sequences and the name list width *)
      blanks := 1 + namelistwidth;

      if not emptyfile(namebook) then blanks:=blanks + (namewidth+1);

{BUBBA uuu
blanks := 0;
this removes the extra blanks for the number
}

      (* 1 blank for orientation character + 1 more for spacing = +2 *)
      if displaylevel = 'p'
      then blanks := blanks + namewidth + (positionwidth+1) +2;
      if displaylevel = 'c'
      then blanks := blanks +             (positionwidth+1) +2;

      if numbered
      then blanks := blanks + (numberwidth+1);

      if usefullname = 'l' (* note the extra blank for padding *)
      then blanks := blanks + fullnamewidth + 1;
{writeln(output,'blanks = ',blanks:1);}
end;

(* begin module alist.startpostscript *)
procedure startpostscript(var a, colors: text;
                          programname: name;
                          deltaXcm, deltaYcm, scaleimage: real;
                          defaultllx: real; (* lower left x *)
                          defaultlly: real; (* lower left y *)
                          defaulturx: real; (* upper left x *)
                          defaultury: real; (* upper left y *)
                          fromdo, todo: integer; (* range of sequences *)
                          sequences: integer; (* number of sequences in book *)
                          cmfactor: real; (* convert from cm to points *)
                          (* the number of lines used by the first page
                             header of clist: *)
                          headerclinenumber: integer);
(* start writing postscript for color text lines to file a, using the colors
file for color definitions.
programname is the name of this program.
deltaXcm and deltaYcm determine how much to move the image on the page.
scaleimage is the scaling factor from the upper left hand corner.
the llx, lly, urx, ury parameters determine where the image resides.
lines is the number of lines to account for vertically.
headercontrol controls the header at the start of the file.
*)
const
   debugging = false; (* debugging the postscript *)
var
   i: integer; (* index to the name n *)
   red,green,blue: real; (* colors *)
   symbol: char; (* one of the bases *)

   currentdisplay: real; (* current display width in points *)
   requireddisplay: real; (* required display width in points *)
   pointcorrection: real; (* requireddisplay - currentdisplay *)
   lines: integer; (* maximum number of lines on a page, based on number
      of sequences *)

   numbarlines: integer; (* lines used by number *)
   actuallines: integer; (* actual lines required for the page *)
begin

   (* compute available page length in lines. *)
   cpagelength := trunc((defaultury-defaultlly)/(fontsize));

   (* we are sure to do the sequences! *)
   actuallines := sequences;

   (* account for the numbar if we are going to do one *)
   if headercontrol <> '0'
   then begin
      numbarlines := firstlastmax(fromdo, todo);
      (* the extra +1 is the dots between the numbar and the sequence *)
      actuallines := actuallines  + numbarlines + 1;
   end;

   (* account for the non-number header lines if we are going to do them *)
   if (headercontrol = 'h')
   then actuallines := actuallines + headerclinenumber;

{
writeln(output,'START>>>> clinenumber = ',clinenumber:1);
writeln(output,'>>>> clinenumber = ',clinenumber:1);
writeln(output,' actual headerclinenumber = ',headerclinenumber:1);
writeln(output,' const  headerclines = ',headerclines:1);
}
   (* At this point the actual number of header lines written out is is 0
      since nothing has been written to clist yet.  But we need to compute
      things from how many there will be later.  To do that, the constant
      headerclines is used.  Just after writing the header the program checks
      that headerclinenumber does indeed match headerclines.  If they don't
      it is a program error and the counting of headerclinenumber should be
      made to match the actual number of clist header lines produced. *)

   if actuallines < cpagelength
   then lines := actuallines
   else lines := cpagelength;

{zboundingbox}
if debugging then begin
writeln(output,'-------------------');
writeln(output,'fromdo      = ',fromdo  :1);
writeln(output,'  todo      = ',  todo  :1);
writeln(output,'numbersize(fromdo)     = ',numbersize(fromdo) :1);
writeln(output,'numbersize(  todo)     = ',numbersize(  todo) :1);
writeln(output,'numbarlines = ',numbarlines:1);
writeln(output,'sequences   = ',sequences  :1);
writeln(output,'headerlines = ',headerlines:1);
writeln(output,'actuallines = ',actuallines:1);
writeln(output,'cpagelength = ',cpagelength:1);
writeln(output,'lines       = ',lines      :1);
writeln(output,'-------------------');
writeln(output,'cmfactor    = ',cmfactor:1:1);
writeln(output,'defaultury         = ',defaultury     :1:1);
writeln(output,'defaultlly         = ',defaultlly     :1:1);
writeln(output,'(defaultury-defaultlly)/cmfactor = ',(defaultury-defaultlly)/cmfactor:1:1);
writeln(output,'(defaultury-defaultlly) = ',(defaultury-defaultlly):1:1);
writeln(output,'-------------------');
writeln(output);
end;

{writeln(output,'edgecontrol = "',edgecontrol,'"');}
   if edgecontrol <> 'p' then begin

      (* figure out the total display width *)
      figureblanks(blanks);
{
writeln(output,'***************************************');
writeln(output,'before startpostscript data available: ');
writeln(output,'blanks = ',blanks:3);
writeln(output,'fromdo = ',fromdo:3);
writeln(output,'todo = ',todo:3);
writeln(output,'columnlength = ',columnlength:3);
writeln(output,'columnwid = ',columnwid:3);
}
      (* the blanks are the part to the left of the numbar
         fromdo and todo are the range of the sequence
         3 is the space around the display (about 1.5 char on both sides)
         columnlength is the length of the columnname *)
      displaywidth := blanks + (todo - fromdo +1) + 3;
      if columnlength > columnwid
      then displaywidth := displaywidth + columnlength
      else displaywidth := displaywidth + columnwid;
{
writeln(output,'displaywidth = ', displaywidth:3);
writeln(output,'***************************************');
}
{
writeln(output,'BEFORE urx = ', urx:1:3);
writeln(output,'fontsize = ', fontsize:1:3);
}

      if colorlistcontrol <> 'R'
      then begin (* portrait *)

         llx := defaultllx; (* lower left x *)
         lly := defaultlly; (* lower left y *)
         urx := defaulturx; (* upper left x *)
         ury := defaultury; (* upper left y *)

         currentdisplay := urx - llx;

         (* at least make sure that the whole display can be seen *)
         requireddisplay := fontsize * defcharacterratio * displaywidth;

         pointcorrection := requireddisplay - currentdisplay;

{
writeln(output,'requireddisplay = ', requireddisplay:1:1);
writeln(output,'currentdisplay  = ', currentdisplay :1:1);
writeln(output,'pointcorrection = ', pointcorrection:1:1);
writeln(output,'AFTER urx = ', urx:1:3);
}

         urx := urx + pointcorrection;

         llx := llx - edgeleft  * cmfactor;
         lly := lly - edgelow   * cmfactor;
         urx := urx + edgeright * cmfactor;
         ury := ury + edgehigh  * cmfactor;

         (* remove extra blanks from the bottom of the bounding box *)
         lly := lly + ((cpagelength - lines) * (fontsize)); {zboundingbox}
{
writeln(output,'(cpagelength - lines) = ',(cpagelength - lines):1);
writeln(output,'fontsize = ',fontsize:1);
}
      end
      else begin (* rotation to landscape *)

         llx := defaultlly; (* lower left x NOTE SWITCH!! *)
         lly := defaultllx; (* lower left y NOTE SWITCH!! *)
         urx := defaultury; (* upper left x NOTE SWITCH!! *)
         ury := defaulturx; (* upper left y NOTE SWITCH!! *)

         currentdisplay := ury - lly;

         (* at least make sure that the whole display can be seen *)
         requireddisplay := fontsize * defcharacterratio * displaywidth;
         pointcorrection := requireddisplay - currentdisplay;
{
writeln(output,'requireddisplay = ', requireddisplay:1:1);
writeln(output,'currentdisplay  = ', currentdisplay :1:1);
writeln(output,'pointcorrection = ', pointcorrection:1:1);
}

         ury := ury + pointcorrection;

         llx := llx - edgehigh  * cmfactor;
         lly := lly - edgeleft  * cmfactor;
         urx := urx + edgelow   * cmfactor;
         ury := ury + edgeright * cmfactor;

         (* remove extra blanks from the bottom of the bounding box *)
         urx := urx - ((cpagelength - lines) * (fontsize)); {zboundingbox}
      end;

      (* move the display around to always match: *)
      llx := llx + deltaXcm * cmfactor;
      lly := lly + deltaYcm * cmfactor;
      urx := urx + deltaXcm * cmfactor;
      ury := ury + deltaYcm * cmfactor;

   end;

writeln(a,'%!PS-Adobe-2.0 EPSF-2.0');
write  (a,'%%Title: ');
for i := 1 to programname.length do write(a,programname.letters[i]);
writeln(a,' ',version:4:2);
writeln(a,'%%Creator: Tom Schneider');
writeln(a,'%%BoundingBox:',
          ' ',round(llx):5,
          ' ',round(lly):5,
          ' ',round(urx):5,
          ' ',round(ury):5);
writeln(a,'%%Pages: 1');
writeln(a,'%%DocumentFonts:');
writeln(a,'%%EndComments');
writeln(a,'%%EndProlog');

 
writeln(a,'/cmfactor 72 2.54 div def % defines points -> centimeters');
writeln(a,'/cm { cmfactor mul} def % defines centimeters');

writeln(a,'/llx ',llx:5:1,' def');
writeln(a,'/lly ',lly:5:1,' def');
writeln(a,'/urx ',urx:5:1,' def');
writeln(a,'/ury ',ury:5:1,' def');

writeln(a,'/edgecontrol (',edgecontrol,') def');
writeln(a,'/edgeleft  ',edgeleft: pwid:pdec,' cm def');
writeln(a,'/edgeright ',edgeright:pwid:pdec,' cm def');
writeln(a,'/edgelow   ',edgelow:  pwid:pdec,' cm def');
writeln(a,'/edgehigh  ',edgehigh: pwid:pdec,' cm def');

   writeln(a);
   (* move image and scale it: *)
   writeln(a,'/deltaXcm ',deltaXcm:10:5,' cm def');
   writeln(a,'/deltaYcm ',deltaYcm:10:5,' cm def');
   writeln(a,'/scaleimage ',scaleimage:10:5,' def');
   writeln(a,'/colorlistcontrol (',colorlistcontrol,') def');

   writeln(a);
   writeln(a,'% based on typefaces program from page 40 of the Blue book');
   writeln(a);
   writeln(a,'% variables');
   writeln(a,'/defcharacterratio ',defcharacterratio:pwid:pdec,' def');
   writeln(a,'/fontsize ',fontsize:1,' def');
   writeln(a,'/lineseparation fontsize def');
   writeln(a,'/thefont /Courier-Bold def');
   writeln(a);
   writeln(a,'% set the font');
(*
original code:
   writeln(a,'thefont findfont fontsize scalefont setfont');
   writeln(a);
*)

   (* 2005 Jan 26: f function for fonts *)
   writeln(a,'/f {findfont fontsize scalefont setfont} def');
   writeln(a,'thefont f');
   writeln(a);
   writeln(a,'/dosymbol {% dosymbol [symbol] - make a symbol');
   writeln(a,'% see page 272 in the Red book');
   writeln(a,'/thissymbol exch def');
   writeln(a,'% switch to the Symbol font');
   writeln(a,'/Symbol f');
   writeln(a,'thissymbol show');
   writeln(a,'% switch back to the standard font');
   writeln(a,'thefont f');
   writeln(a,'} def');

   writeln(a,'/n {');
   writeln(a,'/currenty currenty lineseparation sub def');

   writeln(a,'0 currenty moveto} def');
   writeln(a,'/s {show} def');
   writeln(a,'/sn {s n} def');
   writeln(a);

   writeln(a,'colorlistcontrol (R) ne'); (* default is portrait mode *)
   writeln(a,'{ % normal page display: portrait mode');
   writeln(a,'  /topofpage ',topofpage:pwid:pdec,' cm def');
   writeln(a,'  /startpage{');
{zboundingbox}
   (* the factor of a single fontsize is empirical ... *)
   writeln(a,'  deltaXcm fontsize add deltaYcm translate');
   writeln(a,'  scaleimage dup scale');
   writeln(a,'  0 topofpage moveto');
   (* get current x and y, throw away the x: *)
   writeln(a,'  /currenty currentpoint exch pop def');
   writeln(a,'  } def');
   writeln(a,'}');
   (* --------------------------- *)
   writeln(a,'{ % page rotation to landscape mode');
   writeln(a,'  /topofpage ',0.0:pwid:pdec,' cm def');
   writeln(a,'  /startpage{');
{zboundingbox}
   (* the factor of 1.5 is empirical ... *)
   writeln(a,'  deltaXcm fontsize 1.5 mul add');
   writeln(a,'  deltaYcm fontsize defcharacterratio 2 mul mul add');
   writeln(a,'  translate');
   writeln(a,'  +90 rotate');
   writeln(a,'  scaleimage dup scale');
   writeln(a,'  0 topofpage moveto');
   (* get current x and y, throw away the x: *)
   writeln(a,'  /currenty currentpoint exch pop def');
   writeln(a,'  } def');
   writeln(a,'}');
   writeln(a,'ifelse');
   writeln(a);

(* set up the color statements *)
reset(colors);
if not eof(colors) then while not eof(colors) do begin
   if colors^ <> '*' then begin (* skip comment lines *)
      (* implement the backslash protection scheme: *)
      if colors^ = '\' then get(colors);
      readln(colors,symbol,red,green,blue);

      write(a,'/');
      protectpostscript(a,symbol);
      write(a,symbol,'{');
      if (red = 1.0) or (red = 0.0) then write(a,round(red):1)
                                    else write(a,red:pwid:pdecolor);
      write(a,' ');
      if (green = 1.0) or (green = 0.0) then write(a,round(green):1)
                                        else write(a,green:pwid:pdecolor);
      write(a,' ');
      if (blue = 1.0) or (blue = 0.0) then write(a,round(blue):1)
                                      else write(a,blue:pwid:pdecolor);
      writeln(a,' setrgbcolor (',symbol,') s} def');
   end
   else readln(colors);
end
else begin
   writeln(a,'/a {0 1 0 setrgbcolor (a) s} def');
   writeln(a,'/c {0 0.9372 1 setrgbcolor (c) s} def');
   writeln(a,'/g {1 0.7 0 setrgbcolor (g) s} def');
   writeln(a,'/t {1 0 0 setrgbcolor (t) s} def');
   writeln(a);
end;
   writeln(a,'/b {0 0 0 setrgbcolor} def');  (* set black *)
   writeln(a,'/e {( ) s} def');  (* make empty space *)

end;
(* end module alist.startpostscript *)

procedure readcolumnname(var f: text);
(* read the columnname from file f *)
var
   done: boolean; (* done reading f? *)
begin
   reset(f);
   readvalues := false;
   columnlength := 0;
   if not eof(f) then begin
      get(f); (* skip the "*" *)
      if not eoln(f) then begin
         get(f); (* skip the " " *)
         if not eoln(f) then begin
            while not eoln(f) do begin
               columnlength := succ(columnlength);
               read(f,columnname[columnlength]);
               readvalues := true;
            end;
            readln(f)
         end
      end
   end;

   (* Skip through header information.  If we hit end of file, then there is
      no data and readvalues should be false. *)
   done := false;
   if readvalues then begin
      while not done do begin
         if eof(f) then begin
            readvalues := false;
            done := true
         end
         else begin
            if f^ = '*'
            then readln(f)
            else done := true
         end
      end;
   end;

end;

procedure writecolumnname(var f: text);
(* write the columnname to file f *)
var i: integer; (* index to the column name *)
begin
   for i := 1 to columnlength do write(f,columnname[i]);
end;

procedure getcolumnvalue(var f: text; column: integer; var cvalue: real);
(* get the column value from file f *)
var
   c: integer; (* index to the columns *)
   gotit: boolean; (* whether we got the value *)
begin
  gotit := false;
  while (not eof(f)) and (not gotit) do begin
     if f^='*'
     then readln(f)
     else begin
        for c := 1 to column-1 do skipcolumn(f);
        if not eof(f) then begin
           readln(f,cvalue);
           gotit := true
        end;
     end;
  end;
  if not gotit then begin
     writeln(output, 'getcolumnvalue:  could not locate the column ',
                     column:1,' value');
     writeln(output,'in the avalues file at sequence number ',number:1);
     if eof(f) then writeln(output,'end of file avalues was found');
     halt
  end;
end;

procedure showalignment;
(* show the numbers of all the bases relative to aligned base *)
var
      lines, blanks, index: integer;
begin
   figureblanks(blanks);
   numberbar(list, blanks, fromdo, todo, lines);

   (* now show a bar of dots to make it easier to read *)
   for index:=1 to blanks do write(list, ' ');
   for index:=fromdo to todo do write(list, '.');

   if readvalues then begin
      write(list,' ');
      writecolumnname(list);
   end;

   writeln(list);

   linenumber:=linenumber+lines+1;
end;

procedure cshowalignment;
(* show the numbers of all the bases relative to aligned base
in color *)
var
      lines, blanks, index: integer;
begin
   figureblanks(blanks);

(*
writeln(output,'positionwidth=',positionwidth:1);
writeln(output,'namewidth=',namewidth:1);
writeln(output,'numberwidth=',numberwidth:1);
writeln(output,'blanks=',blanks:1);
*)

   pnumberbar(clist, blanks, fromdo, todo, lines);

   (* now show a bar of dots to make it easier to read *)
   write(clist,'(');
   for index:=1 to blanks do write(clist, ' ');
   for index:=fromdo to todo do write(clist, '.');

   if readvalues then begin
      write(clist,' ');
      writecolumnname(clist);
   end;
   write(clist,') sn');

   if cpagenumber > 1 then removeit(clist)
                      else writeln(clist);

   clinenumber:=clinenumber+lines+1
end;

procedure showpage(var a: text);
(* show the page *)
begin
   writeln(a,'b');
   write(a,'showpage'); removeit(a)
end;

(* begin module checknumber *)
function checknumber(var afile: text): boolean;
(* check that there is a number next in the file.  If not, return
false.   This is useful for protection when reading a parameter file. *)
var ok: boolean; (* result of this check *)
procedure conclude;
begin
   writeln(output,'Including this character, the rest of the data line is:');
   copyaline(afile,output);
   ok := false;
end;
begin
   ok := true; (* be optimistic *)
   if eof(afile)
   then begin
      ok := false;
      write  (output,'A number was expected on a data line, but');
      writeln(output,' the end of the file was found instead.');
   end
   else begin
      skipblanks(afile);
      if eoln(afile) then begin
         write  (output,'A number was expected on a data line, but');
         writeln(output,' the end of the line was found instead.');
         conclude;
      end;
      if not (afile^ in
         ['0','1','2','3','4','5','6','7','8','9','.','-','+']) then begin
         write  (output,'A number was expected on a data line, but');
         writeln(output,' the character "',afile^,'" was found instead.');
         conclude;
      end;
   end;
   checknumber := ok
end;
(* end module checknumber version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module copyfile *)
procedure copyfile(var fin, fout: text);
(* copy the rest of file fin to fout *)
begin
   while not eof(fin) do copyaline(fin, fout);
end;
(* end module copyfile version = 5.27; (@ of prgmod.p 2005 Aug 06 *)

(* begin module almostcopyfile *)
procedure almostcopyfile(var fin, fout: text); 
(* copy file fin to fout EXCEPT the last line,
which for an old alist file was:
alistp: parameters for alist 5.85 and higher
This is detected by an 'a' being in the first line.
Crude but effective ... *)
begin
   while not eof(fin) do begin
      if fin^ <> 'a'
      then copyaline(fin, fout)
      else readln(fin);
   end;
end;
(* end module almostcopyfile *)

(* begin module alist.upgradeto596 *)
procedure upgradeto596;
(* upgrade the alistp file to version 5.96.  This allows
me to do multiple upgrade routines. *)
var
   internal: text; (* a place to hold the old alistp *)
begin
   parameterversion := 5.96;
   writeln(output, 'upgrading to version ',parameterversion:4:2,' ...'); 
   reset(alistp);
   (* there was no version parameter to skip before this point *)
   rewrite(internal);
   almostcopyfile(alistp, internal); 

   rewrite(alistp);
   writeln(alistp,parameterversion:4:2,'        version of',
         ' alistp that this parameter file is designed for.');

   reset(internal);
   copyfile(internal, alistp); 

   (* add the new material at the end: *)

   writeln(alistp,
      'n 0 0 0 0   edgecontrol (p=page),',
      ' edgeleft, edgeright, edgelow, edgehigh in cm');

   reset(alistp); (* ready to start reading again *)
end;
(* end module alist.upgradeto596 *)

(* begin module alist.upgradeto598 *)
procedure upgradeto598;
(* upgrade the alistp file to version 5.98:
add fontsize and the deltaXcm, deltaYcm, and scaleimage parameters *)
var
   internal: text; (* a place to hold the old alistp *)
begin
   parameterversion := 5.98;
   writeln(output, 'upgrading to version ',parameterversion:4:2,' ...'); 

   (* copy alist to internal *)
   reset(alistp);
   readln(alistp); (* skip old parameter version line *)
   rewrite(internal);
   copyfile(alistp, internal);

   (* copy internal to alist *)
   reset(internal);
   rewrite(alistp);
   writeln(alistp,parameterversion:4:2,'        version of',
         ' alistp that this parameter file is designed for.');
   copyfile(internal, alistp);

   (* add the new material at the end: *)
   writeln(alistp, defcolorlistcontrol:1, ' ',deffontsize:1,
      '        mapcontrol:',
      ' C=do map, R= rotate, char height (72 points/inch)');

   writeln(alistp,     defdeltaXcm:3:1,
                 ' ',  defdeltaYcm:4:1,
                 ' ',  defscaleimage:3:1,
                 ' amount to move image in x and y (cm) and scale factor');
   reset(alistp); (* ready to start reading again *)
end;
(* end module alist.upgradeto598 *)

(* begin module alist.upgradeto620 *)
procedure upgradeto620;
(* upgrade the alistp file to version 6.20:
add fontsize and the deltaXcm, deltaYcm, and scaleimage parameters *)
var
   internal: text; (* a place to hold the old alistp *)
begin
   parameterversion := 6.20;
   writeln(output, 'upgrading to version ',parameterversion:4:2,' ...'); 

   (* copy alist to internal *)
   reset(alistp);
   readln(alistp); (* skip old parameter version line *)
   rewrite(internal);
   copyfile(alistp, internal);

   (* copy internal to alist *)
   reset(internal);
   rewrite(alistp);
   writeln(alistp,parameterversion:4:2,'        version of',
         ' alistp that this parameter file is designed for.');
   copyfile(internal, alistp);

   (* add the new material at the end: *)
   writeln(alistp, 'h           headercontrol: h(eader);',
                   ' 0: no header, no numbar; else numbar');

   reset(alistp); (* ready to start reading again *)
end;
(* end module alist.upgradeto620 *)

(* begin module alist.upgradeparameters *)
procedure upgradeparameters(var alistp: text);
(* make sure that the parameters are the latest spiffy version *)
begin
   readln(alistp, parameterversion);
   if parameterversion < updateversion then begin
      writeln(output, 'You have an old parameter file, version ',
              parameterversion:4:2,'!');
      if parameterversion < 5.96 then upgradeto596;

      reset(alistp);
      readln(alistp, parameterversion);
      if parameterversion < 5.98 then upgradeto598;

      reset(alistp);
      readln(alistp, parameterversion);
      if parameterversion < 6.18 then upgradeto620;

      reset(alistp);
      readln(alistp, parameterversion);
      if parameterversion < updateversion then begin
         writeln(output, 'Sorry! I am unable to fully upgrade',
                         ' your parameter file');
         writeln(output, 'from version ', parameterversion:4:2,
                          ' to version ', updateversion:4:2,'!');
         writeln(output, 'Start from a fresh copy or edit this one.');
         halt;
      end
      else writeln(output, '... upgrade successful!');

      writeln(output, 'See this page for the new documentation:');
      writeln(output,
         'https://alum.mit.edu/www/toms/delila/alist.html');
   end;
end;
(* end module alist.upgradeparameters *)

(* begin module alist.readparameters *)
procedure readparameters;
(* read the parameters *)
var
   checkout: boolean; (* if true, all variable values are ok *)
procedure cn;
(* short version of call to check number *)
begin
  checkout := checknumber(alistp);
  if not checkout then halt; (* avoid snowballing *)
end;
begin (* readparameters *)
   (* predefine all the parameters so the parameter file
      can have some missing - this probably should be removed ... *)
   fromdo := fromparam;
   todo := toparam;
   userrange := false;
   displaylevel := ' ';
   shownumbers := ' ';
   usefullname := ' ';
   paging := ' ';
   alignmenttype := 'i';
   column := 6;
   columnwid := 6;
   columndec := 2;
   edgecontrol := 'p';
   fontsize := deffontsize;
   deltaXcm := defdeltaXcm;
   deltaYcm := defdeltaYcm;
   scaleimage := defscaleimage;
   colorlistcontrol := ' ';
   mapcontrol := false;
   headercontrol := 'h';

   (* read parameters *)
   reset(alistp);
   if not eof(alistp) then begin
      upgradeparameters(alistp);

      readln(alistp, fromdo, todo);
      if fromdo > todo then begin
         writeln(output,'from position (',fromdo:1,
                        ') must be less than or equal to to position (',
                        todo:1,')');
         halt
      end;
      userrange := true;

      if not eof(alistp) then readln(alistp,displaylevel,usefullname, shownumbers);

      if not eof(alistp) then readln(alistp,paging);

      if not eof(alistp) then begin
         readln(alistp,alignmenttype);
         if not (alignmenttype in ['f','i','b']) then begin
            writeln(output,'alignment type must be f, b, or i');
            halt
         end;
      end;

      if eof(alistp) then begin
         writeln(output,'you are missing parameter',
                        ' columntoread etc of alistp!');
         halt
      end;
      cn; readln(alistp,columntoread,columnwid,columndec);

      if eof(alistp) then begin
         writeln(output,'you are missing parameter',
                        ' edgecontrol etc of alistp!');
         halt
      end;

      read(alistp, edgecontrol);
      if (edgecontrol <> 'p')
      then begin
         read(alistp, edgeleft, edgeright, edgelow, edgehigh)
      end;
      readln(alistp);

      if eof(alistp) then begin
         writeln(output,'you are missing parameter',
                        ' fontsize etc of alistp!');
         halt
      end;

      read(alistp,colorlistcontrol);
      if colorlistcontrol in ['C','R'] then begin
         mapcontrol := true;
         cn;  readln(alistp, fontsize);
      end
      else begin
         readln(alistp);
         mapcontrol := false;
      end;

      cn; read(alistp,deltaXcm);
      cn; read(alistp,deltaYcm);
      cn; readln(alistp,scaleimage);

      readln(alistp, headercontrol);

   end;
end;
(* end module alist.readparameters *)

(******************************************************************************)
(******************************************************************************)
(******************************************************************************)

begin
   writeln(output,'alist ',version:4:2);
   readparameters;

   (* conversion factor from cm to points *)
   cmfactor := 72 / 2.54 ; (* (72 points / inch) / (2.54 cm per inch) *)

   rewrite(list);
   rewrite(clist);

   linenumber  := 0;
   if headercontrol = 'h' then begin
      writeln(list,'alist ',version:4:2,', aligned listing of book:');
      linenumber := linenumber + 1;
      splitbooktitle(book, list);
      linenumber := linenumber + 2; (* the split makes two lines! *)
   end;

   (* this test must be done before the call to startpostscript! *)
   clinenumber  := 0;
   if (headercontrol = 'h') or (headercontrol <> '0')
   then headerclinenumber := headerclines
   else headerclinenumber := 0;

   pagenumber:=1;
   cpagenumber:=1;

   (* get the column name *)
   readcolumnname(avalues);

   (* start reading the inst file *)
   reset(inst);
   if eof(inst) then if alignmenttype = 'i' then begin
      writeln(output,'forcing alignment to be on book',
                     ' because there are no instructions');
      alignmenttype := 'b'
   end;

   (* start reading the book file *)
   new(apiece);
   brinit(book, theline);
   if displaylevel = 'p'
   then maxname(book, theline, 'p', namewidth, list, linenumber,
                 org, orgchange, orgopen,
                 chr, chrchange, chropen,
                 pie, piechange, pieopen)
   else maxname(namebook, theline, 'g', namewidth, list, linenumber,
                 org, orgchange, orgopen,
                 chr, chrchange, chropen,
                 pie, piechange, pieopen);
   reset(namebook);
   orgchange := false; chrchange := false; piechange := false;
   orgopen   := false; chropen   := false; pieopen   := false;

   maxnamelist(namelist,namelistwidth);
   namelistuse := (namelistwidth > 0);
   reset(namelist);
   maxfullnamewidth(book,theline,fullnamewidth);
   brinit(book,theline);

   getpositions(inst, book, positionwidth, numberwidth, sequences,
                alignmenttype);
   writeln(output,sequences:1,' sequences in the book');

   maxminalignment(inst,book,theline, fromparam,toparam,alignmenttype);

   writeln(output, 'available range: ',fromparam:1, ' ',toparam:1);

   programname.letters[1] := 'a';
   programname.letters[2] := 'l';
   programname.letters[3] := 'i';
   programname.letters[4] := 's';
   programname.letters[5] := 't';
   programname.length := 5;
   startpostscript(clist,colors,programname,
                          deltaXcm, deltaYcm, scaleimage,
                          defaultllx, defaultlly, defaulturx, defaultury,
                          fromdo, todo, sequences, cmfactor,
                          headerclinenumber);

   writeln(clist,'startpage');
   if headercontrol = 'h' then begin
      write(clist,'(alist ',version:4:2,', aligned listing of book: ) sn');
      noheader(clist);
      clinenumber := clinenumber + 1;

      (* copy the book title to the clist on two lines: *)
      write(clist, '(');
      copytocomma(book, clist);
      copytocomma(book, clist);
      write(clist, ') sn');
      noheader(clist);
      clinenumber := clinenumber + 1;

      write(clist, '(');
      write(clist, ' '); (* nifty extra space at start aligns things *)
      copynoreturn(book, clist);
      write(clist, ') sn');
      noheader(clist);
      clinenumber := clinenumber + 1;

      noheader(clist);

      write(output,'alignment by ');
      write(list,'The alignment is by ');
      case alignmenttype of
         'f': begin
            writeln(output,'first base');
            writeln(list,'first base');
         end;
         'i': begin
            writeln(output,'delila instructions');
            writeln(list,'delila instructions');
         end;
         'b': begin
            writeln(output,'book coordinates');
            writeln(list,'book coordinates');
         end;
      end;
      linenumber := linenumber + 2;

{
   (* It isn't clear to me at the moment what the actual range of the book is
      in the other cases, so it is best not to report the wrong thing! *)
   if alignmenttype = 'i' then begin 
1997 April 23 - I think it's ok now.
}
      writeln(list, 'The book is from:       ', fromparam:1, ' to ', toparam:1);
      linenumber := linenumber + 1;
      write(clist, '(The book is from:       ', fromparam:1, ' to ', toparam:1,') sn');
      noheader(clist);
      clinenumber := clinenumber + 1;
{
   end;
}

      writeln(list, 'This alignment is from: ', fromdo:1, ' to ', todo:1);
      writeln(list);
      linenumber := linenumber + 2;
      write(clist, '(This alignment is from: ', fromdo:1, ' to ', todo:1,') sn');
      noheader(clist);
      clinenumber := clinenumber + 1;

      (* check that the number of header lines actually written matches
         the constants at the top of the program. *)
{
      headerlinenumber := linenumber;
      if headerlinenumber <> headerlines then begin
         writeln(output,'program list header problem');
         writeln(output,' actual headerlinenumber = ',headerlinenumber:1);
         writeln(output,' const  headerlines = ',headerlines:1);
         halt;
      end;

      headerclinenumber := clinenumber;
      if headerclinenumber <> headerclines then begin
         writeln(output,'program clist header problem');
         writeln(output,' actual headerclinenumber = ',headerclinenumber:1);
         writeln(output,' const  headerclines = ',headerclines:1);
         halt;
      end;
2001 Mar 26:  If one turns off piece names this changes -
I'm not sure why I put this check in, but it seems unreasonable.
Probably some other program depends on the header lines matching?
}

   end;

{
   else headerclinenumber := headerclines;
   else headerclinenumber := clinenumber;
writeln(output,'>>>> clinenumber = ',clinenumber:1);
writeln(output,' actual headerclinenumber = ',headerclinenumber:1);
writeln(output,' const  headerclines = ',headerclines:1);
}

   if (headercontrol = 'h') or (headercontrol <> '0') then begin
      showalignment;
      cshowalignment;
   end;

   while not eof(book) do begin
      case alignmenttype of
         'i': align(inst,book,theline,apiece,length,alignedbase);
         'b','f': begin
              getpiece(book,theline,apiece); (* read in the piece *)
              length := piecelength(apiece);
         end;
      end;

      if not eof(book) then begin

         case alignmenttype of
            'f': alignedbase := 1; (* force alignment on first base *)
            'i': ; (* use the alignedbase from the book *)
            'b': alignedbase := pietoint(0, apiece); (* use the internal book *)
         end;

         writeln(clist, 'b');

         if usefullname = 'l' then begin
            write(clist,'(');
            with apiece^.key.hea.fulnam^ do begin
               for index := 1 to length do begin
                  write( list,letters[index]);
                  write(clist,letters[index]);
               end;
               (* note the extra blank for padding *)
               for index := length+1 to fullnamewidth+1 do begin
                  write(clist,' ');
                  write( list,' ');
               end;
            end;
            writeln(clist,') show');
         end;

         if (displaylevel = 'p') or
            (displaylevel = 'c') then begin
{
writeln(output,'displaylevel is p');
writeln(output,'namewidth = ',namewidth:1);
for index := 1 to namewidth
do write(output,apiece^.key.hea.keynam.letters[index]);
writeln(output,'done');
}

            if (displaylevel = 'p')
            then for index := 1 to namewidth
               do write(list,apiece^.key.hea.keynam.letters[index]);

{zzzqqq
positionwidth := 20;
}

            write(list,' ',inttopie(alignedbase,apiece):positionwidth);

            write(clist,'(');
            if (displaylevel = 'p')
            then for index := 1 to namewidth
               do write(clist,apiece^.key.hea.keynam.letters[index]);

            write(clist,' ',inttopie(alignedbase,apiece):positionwidth);

            write(clist,') s ');
         end
         else if not emptyfile(namebook)
              then printname(namebook, theline, nametype, namewidth,
                             list, clist,
                 org, orgchange, orgopen,
                 chr, chrchange, chropen,
                 pie, piechange, pieopen,
                             linenumber, clinenumber);

         if namelistuse then begin
            write(list,' '); (* extra blank in front of name *)
            write(clist,'( '); (* extra blank in front of name *)
            index := 0;
            while not eoln(namelist) do begin
               index := index + 1;
               read(namelist,cnamelist);
               write(list,cnamelist);
               write(clist,cnamelist)
            end;
{zzz}
            for indexfill := 1 to namelistwidth - index - 1
            do begin
               write( list,' ');
               write(clist,' ');
            end;
            writeln(clist,') show');
            readln(namelist);
         end;

         if (displaylevel = 'p') or
            (displaylevel = 'c') then begin
            (* give the orientation *)
            if apiece^.key.piedir = minus then thedirection := '-'
                                          else thedirection := '+';
            write(list,' ',thedirection);
            writeln(clist, '( ',thedirection,') s');
         end;

         if numbered and (shownumbers <> '-')
         then write(list, ' ', number:numberwidth, ' ');
{ 2012 mar 31: no blank if no number!!
         else write(list, ' '                         );
}

         if numbered and (shownumbers <> '-')
         then writeln(clist, '( ', number:numberwidth, ' ) s');
{ 2012 mar 31: no blank if no number!!
         else writeln(clist, '(',' ':numberwidth,') s');
}

         column := 0;
         for index := fromdo to todo do begin
            if withinalignment(index, alignedbase, length)
            then begin
               b := basetochar(getbase(index+alignedbase, apiece));
               write(list,b);
               write(clist,' ',b);
            end
            else begin
               write(list, ' ');
               write(clist, ' e');
            end;
            column := column + 2;
            (* note: the number in the next line must be divisible
               by 2 or the lines will never be broken *)
            if (column mod 76) = 0 then begin
               writeln(clist);
               column := 0
            end;
         end;

         (* give the avalue column *)
         if readvalues then begin
            getcolumnvalue(avalues, columntoread, columnvalue);
            write(list,' ',columnvalue:columnwid:columndec);
            write(clist,' ( ',columnvalue:columnwid:columndec,') b s');
         end;

         writeln(list);
         writeln(clist,' n');

         linenumber:=succ(linenumber);
         clinenumber:=succ(clinenumber);
         if paging <> 'n' then begin
            if linenumber > cpagelength then begin (* modified 2002 apr 19 *)
               page(list);
               pagenumber:=succ(pagenumber);
               writeln(list, 'page ', pagenumber:1);
               linenumber:=2;
               showalignment
            end;

            (* paging is done to the clist at all times!
               2001 Nov 5 - well poo on that!! *)
            (* 2007 Nov 29 change from > to >= *)
            if clinenumber >= cpagelength then begin
               cpagenumber:=succ(cpagenumber);
               (* just at the end of a page make sure that the printer
               is reset to black printing by the 'b' function *)
               showpage(clist);
               write(clist,'startpage'); removeit(clist);
               write(clist, '(page ', cpagenumber:1,') sn'); removeit(clist);
               clinenumber:=2;
               clinenumber:=1; (* 2007 Nov 29 *)
               cshowalignment
            end;

         end;

         clearpiece(apiece);
      end
   end;
   if clinenumber > 2 then showpage(clist); removeit(clist);

   (* create end of EPS file *)
   writeln(clist,'%%Trailer');

1: end. (* alist *)
