program makelogo(symvec, makelogop, colors, marks,
                 wave, logo, output);
(* makelogo: make a graphical `sequence logo' for aligned sequences

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

module libraries required: delman, prgmods *)

label 1; (* end of program *)

const
(* begin module version *)
   version = 9.67; (* of makelogo.p 2023 Jan 02
2023 Jan 02, 9.67: PLOS ONE had trouble with the Times font in a logo.
                   I was using:
                   /FontForStringItalic  {/Times-BoldItalic ffss} def
                   I switched to:
                   /FontForStringItalic  {/Helvetica-BoldItalic ffss} def
2020 Mar 06, 9.66: link to https://alum.mit.edu/www/toms/logorecommendations.html
2020 Mar 06, 9.65: fix documentation about variable logos
2018 Aug 08, 9.64: show squashed letters as rectangles
2018 Jul 26, 9.63: working on squash-spray: hidden variable
2018 Jul 25, 9.62: working on squash-spray: hard wired
2018 Jul 25, 9.61: attempt to solve near zero height letter squash-spray
2017 Jul 03, 9.60: tic marks on y axis were covered by bar width.
                   solution: set barwidth from 0.1 to 0.05 in makelogop.
2015 Aug 12, 9.59: make the flat logo scale go from 0 to 1 with 'frequency'
                   instead of bits.
2015 Jul 30, 9.58: switch from Times-Bold to Helvetica-Bold for strings!!
2015 Jan 15, 9.57: equallogo = flat logo is missing columns
2014 Dec 29, 9.56: clean up
2014 Dec 29, 9.55: \d1 leaves 2 decimals for Rs!  see putreal
2014 Jun 19, 9.54: upgrade reference keys
2014 Jan 30, 9.53: tidy up escape protection
2014 Jan 30, 9.52: protect against titles with unidentified '\' escape
2013 Jun 26, 9.51: add halt if shrink parameters are wrong.
2013 Jan 25, 9.50: checkingi Ibeamfraction documentation
2012 Apr 19, 9.49: fix documentation
2011 Apr 14, 9.48: compute information density, subtract gap positions
2011 Apr 14, 9.47: compute information density
2011 Apr 06, 9.46: change name from lambdacicro.logo to lambdacicro-logo.ps
2011 Apr 05, 9.45: add alt tags to images
2011 Apr 05, 9.44: fix documentation on form control
2011 Mar 09, 9.43: fix documentation
2011 Mar 09, 9.42: formcontrol rareequal
2011 Mar 09, 9.41: more documentation
2011 Mar 09, 9.40: normallogo, equallogo, varlogo examples
2011 Mar 09, 9.39: equallogo, varlogo implemented
2011 Mar 09, 9.38: prepare for equallogo, varlogo, rarelogo; rarelogo implemented!
2007 Mar 31, 9.37: allow blank lines in colors file.
                   lower case in colors for DNA/RNA, upper for protein
2007 Jan 09, 9.36: display of reals in the strings has a bug!
                   10.07368 became 10.7367
                    0.00669 became  0.669
                   \r and \s are affected.
                   in module makelogo.postscriptstring
                   also affects denplo.  Solution is in putreal
2006 Oct 25, 9.35: set minimumStackSize.
2005 Sep  6, 9.34: typo correction
2005 Jan  4, 9.33: ibeam and barend documentation
2003 Aug 21, 9.32: clean up
2003 Aug 21, 9.31: subtic bug, changes on multiple lines
2003 Jul 15, 9.30: implement second subtic commands: subticsSmall
2003 Jul 14, 9.29: implement subtic commands
2003 Jul 14, 9.28: investigate intermediate (non-integer) tic marks
2003 Jul 14, 9.27: clean up
2003 Jul 14, 9.26: controls for bars on ends (barends is b, l or r)
2002 Aug 31, 9.25: better warnings when llx, lly, urx, ury set incorrectly
2002 Apr 17, 9.24: FULL WORKING EXAMPLE
2001 May 13, 9.23: charwidth2m defined to allow marks.lettering
2000 Dec 15, 9.22: glossary and logo picture
2000 Dec 15, 9.21: error bar / number overlap bug discussion
2000 Dec  1, 9.20: bar (param 2) documentation improved.
2000 Nov  1, 9.19: finalize dash method
2000 Oct 30, 9.16: upgrade to new dash method
2000 Oct 18, 9.15: upgrade documentation
2000 Sep 2, 9.14: markscontrol accounted for
2000 June 24, 9.13: edge controls rotate with image
2000 June 19, 9.12: zerobase upgraded to functioning.
2000 March 17, 9.11: visibility control
2000 March 13, 9.07: upgrade documentation for see also
1999 August 30, 9.06: removed 'packed' from map definition; now
     it compiles and runs with gpc!!!
1999 April 12, 9.02: ability to toggle outline using marks file.
1999 March 11, 8.94: modify so that waves can be moved to lister
1999 March 8, 8.93: allow multiple \n in strings
1999 March 5, 8.92: update marks to match lister
1999 February, 21 8.88: \r and \s use range of logo
1999 February, 21 8.85: implemented \d
1999 February, 20 8.84: implemented \r and \s
1998 December, 2: add a few more marks file examples
origin 1990 Feb 28 from rsgra *)
(* end module version *)

(* begin module describe.makelogo *)
(*
name
   makelogo: make a graphical `sequence logo' for aligned sequences

synopsis
   makelogo(symvec: in, makelogop: in, colors: in, marks: in,
            wave: in, logo: out, output: out)

files
   symvec:  A "symbol vector" file usually created by the alpro or dalvec
     program.  Makelogo will ignore any number of header lines that begin
     with "*".  The next line contains one number (k) that defines the number
     of letters in the alphabet.  and then defines the composition of letters
     at each position in the set of aligned sequences.

     Each composition begins with 4 numbers on one line:

     1. position (integer);
     2. number of sequences at that position (integer);
     3. information content of the position (real);
     4. variance of the information content (real).

     This is followed by k lines.  The first character on the line
     is the character.  This is followed by the number of that character
     at that position.  

     Example:

* position, number of sequences, information Rs, variance of Rs
4 number of symbols in DNA or RNA
-100       86 -0.00820  6.3319e-04
a   27
c   18
g   20
t   21
 -99       86 -0.00436  6.3319e-04
a   26
c   19
g   17
t   24

     * If the symvec file is empty, the alphabet is printed as a test.

     * If the error bars values are negative, they are not displayed.  This
     allows the sites program to control the display when it would not be
     appropriate.

     * If the number of a symbol is negative in symvec, then the symbol will
     be rotated 180 degrees before being printed.  The absolute value is used
     by makelogo to determine the height.  This allows statistical tests
     which find rare symbols to be significant to show that the symbol is
     rare by having it up side down.  Notice that ACGT are all easy to
     distinguish from their upside down versions, but unfortunately this is
     not always true for protein sequences.  Program dalvec contains a switch
     for turning the letters over in the ChiLogo.

   makelogop: parameters to control the program.

     line 1: contains the lowest to highest range of the binding site to do
                    the logo graph. (FROM to TO range)

     line 2: bar: sequence coordinate before which to print a vertical bar
             NOTE: the vertical bar takes up a small amount of horizontal
             space.  However, to make sure that marks are placed correctly,
             the logo is not offset.  The bar will overwrite the previous
             stack and the next stack will overwrite the bar.
             To remove the bar, just set its location outside the range
             of the display.

     line 3: xcorner and ycorner.  This is the coordinate of the lower left
             hand corner of the logo (in cm).  These should be real numbers.

             z xcorner ycorner zerobase
             If the first letter of this line is "z", then the program
             expects three numbers:  xcorner, ycorner and zerobase.  Zerobase
             is a real number defining the position on the sequence that the
             zero of the coordinate system is to be set.  For example,
             setting zerobase to 0 (zero) will place the center of the 0 at
             xcorner, ycorner.  This special feature allows the logo to be
             precisely placed relative to other logos so that they can be
             aligned one above another in a figure.

     line 4: rotation: angle in degrees to rotate the logo.  Warning:
             rotations other than by factors of 90 degrees may produce
             incorrect logos because character scaling depends on the
             orientation of the characters.  (Essentially, it's a design
             fault of PostScript.)

     line 5: charwidth: (real, > 0) the width of the logo characters, in cm
             squashspray (real, > 1.0 - optional.

             2018 Jul 26: If there is a second number after the
             charwidth, this becomes squashspray.  Make this value
             larger than '1.0' if you are getting a line to the right
             of your logo; these are squashed letters that are too
             small.  After being squashed they are sprayed to the
             right of the logo for unknown reasons.  This appears to
             be a bug in PostScript interpreters and printers.  If a
             character height is smaller than squashspray, it is drawn
             as a solid rectangle.  Most of the time a user will not
             notice this.  You can see them by making squashspray a
             large value (e.g. 80).  See the technical notes for how
             and why to use this.

     line 6: barheight barwidth: (real, > 0) height of the vertical bar, in
             cm, and its width, in cm.

             WARNING: if the barwidth is too big, it can cover the
             smaller tic marks.

     line 7: barbits: (real) The height of the vertical bar, in bits, is
             given by the absolute value of barbits.  If barbits is positive,
             an "I-beam" will appear at the top of the symbol stack.  The
             I-beam indicates one standard deviation of the stack height,
             based entirely on how small the sample of sequences is.  If the
             value of barbits is negative, the I-beam is not displayed.  Not
             knowing how big the sampling effects are can fool one, so one
             should usually have the I-beam, even if it is ugly.

                WARNING: it is not known how to calculate the error for data
             derived from a dirty DNA synthesis experiment (see
             Schneider1989, reference given below).  In that case the error
             could be calculated (in program sites) from the number of
             sequences, so that the error bar would be an underestimate of
             the variation.  Unfortunately, when I tried this, people
             interpreted the error bar as the size they saw, so this does not
             work well visually.  Therefore when data come from the sites
             program, the I-beam is suppressed.

                The combination of barheight and barbits determines the size
             of the logo in bits per centimeter.  Both must be specified even
             if no vertical bar is desired.

     line 8: Ibeamfraction: real. The fraction of the vertical part of the
             Ibeam to draw.  When it is 1, the Ibeam is normal.  When it is
             zero, no vertical line is drawn.  At 0.1, only 10 percent of the
             top half and 10 percent of the bottom half of the Ibeam is
             drawn, for a total of 10 percent of the entire ibeam.  More
             precisely, this number is the fraction of a standard deviation
             to draw.  Negative values will reverse the direction of the part
             drawn, making a 'thumbtack'.  (Note:  if this parameter is
             missing, as in old makelogop files, the program will ignore
             it.)  I thank Shmuel Pietrokovski (Structural Biology
             department, Weizmann Institute of Science, 76100 Rehovot -
             ISRAEL, bppietro@dapsas1.weizmann.ac.il) for suggesting this
             method, and for the code to do it.  See further description
             below.

             Note:  This parameter can be skipped.  The code looks for
             a number at this position in the parameter file.  If
             there is a number, the Ibeamfraction is read.  Otherwise,
             the Ibeamfraction defaults to 1.0.

     line 9: barends: if the first character on the line is a 'b', then bars
             are put before and after each line, in addition to the other
             bar.  The first bar on each line is labeled with tic marks and
             the number of bits.  If you don't want this, you can remove the
             call to maketic in the logo.  This is easily done in Unix with

               grep -v maketic.startline logo > logo.without.tics

             That is, the PostScript code that generates the tic marks is on
             one line and there is a comment containing "maketic.startline".
             The grep removes that entire line from the logo file.  Likewise,
             the bars at the start and end of the lines can be removed with:

               grep -v makebar.startline logo > logo.without.start.bar
               grep -v makebar.end linelogo   > logo.without.end.bar

             If barends is:

                b - put a bar on both left and right sides of the logo
                l - left only
                r - right only
                n - no bar on either side

             One can control tic marks that are not numbered.  These
             are called 'subtics' and they are controlled by the
             second character on the line.

             If the second character on the line (ticcommand) is:

                t - it is followed by two numbers: subticsBig and    
                    subticsSmall.

                    Both numbers define the number of intervals of sub-tic
                    marks to show for each vertical bit of
                    the bar.

                    subticsBig is the number of intervals for big subtics.
                    These are the same size as the numbered tics.

                    subticsSmall is the number of intervals for small subtics.
                    These are half the size as the numbered tics.

                    Examples:

                    't 2 10' will put a big tic at 0.5 and 1.5 bits
                    and small tic marks every 0.1 bit.  This is the
                    default.

                    't 2 2' will put a big tic at 0.5 and 1.5 bits
                    There will also be small tic marks but since they
                    are in the same location as the big ones, you
                    would not see them.)

                    't 1 1' will make the tic marks fall under the
                    numbered tic marks so none are visible.

                    WARNING: if the barwidth is 0.1 (the previous
                    standard) then the tic marks will get covered.  A
                    barwidth of 0.05 works.

                Any other character for ticcommand will be the same as
                't 2 10', so this is the default.

    line 10: showingbox: if the first character on the line is an 's', then
             show a box around each character.  This is useful to check that
             the heights of the letters are correct and to distinguish the
             letters from each other when amino acids are represented.

             If the character is an 'f', then the box is filled and no
             character is shown.  This is useful for showing 'logos' of
             extremely large size where the individual character is not
             readable, but the color is.

    line 11: outline:  If the first character is 'o' then the characters show
             up in outline form.  Otherwise, they are solid.

             The outline of an entire stack can be turned on or off using the
             marks file.  The command is toggleoutline and it is treated as a
             user defined command.  The first parameter is the position, the
             remaining three must be given but are ignored.  The state of the
             outlining will apply to the stack following the given position.
             For example,

U 0 0 0 0 toggleoutline
U 1 0 0 0 toggleoutline

             will set position 1 to be the reverse of the rest of the logo.
             (New as of 1999 April 12)

    line 12: caps: if the first letter is 'c' then alphabetic characters are
             converted to capital form.

    line 13: stacksperline: number of character stacks per line output.  A
             "stack" is a vertical set of characters.  A "line" is a series
             of stacks.  One may have several lines per page (next
             parameter).  Special note: This value is used to do the
             centering of strings.  For a range of -23 to +19, you have to
             set it to (19)-(-23)+1 = 43 to get your title centered
             correctly.  You can get the program to tell you the number '43'
             by setting stacksperline very large, in which case it realizes
             there is something wrong and does the calculation.

    line 14: linesperpage: number of lines per page output

    line 15: linemove: line separation relative to the barheight Note:  This
             affects the BoundingBox discussed below.

    line 16: numbering: if the first letter is 'n' then each stack is
             numbered.  Otherwise, the number is suppressed in a PostScript
             if statement.  This allows you to modify the logo file by hand
             to reinstate numbering for only the positions you want by
             removing or changing the if statement calls to makenumber.  For
             example,

                numbering {(6) makenumber} if

             Is the PostScript for making the number "6" under the global
             numbering control.  To make "6" always be there, change it to:

                true {(6) makenumber} if

    line 17: shrinking: (real)  Factor by which to shrink the characters.  If
             shrinking <= 0 or shrinking >= 1 then the characters exactly fit
             into the box.  If shrinking > 0 and shrinking < 1, the
             characters are shrunk inside the box.  To use this feature, the
             parameter showningbox be on, so that the user does not create a
             logo whose height is misleading.

    line 18: strings: the number of user defined strings to follow.  Each
             string definition takes up two lines.  The first is the (x,y)
             coordinate of the string, the second is the string itself.  The
             coordinates are in centimeters relative to the coordinate
             transforms performed above.  (This way, the title position stays
             the same relative to the logo.)

    line 18+strings+1: (x,y,s) coordinates of first user defined string (if
             strings >= 1) followed by the factor by which to scale the
             string.  A factor of 1 means no scaling.  In addition, if the x
             coordinate is less than or equal to -1000, then the string is
             centered by using the string width, the stacksperline and
             charwidth.  Note!  To allow more parameters, it is no longer
             true that one may turn off the strings by setting the number of
             strings to 0, but the lines can be left in the file.  If strings
             are zero, then they must be removed.

    line 18+strings+2: the first user defined string (if strings >= 1)

    line 18+strings+3: (x,y,s) coordinates of second user defined string (if
            strings >= 2)

    line 18+strings+3: (x,y,s) coordinates of second user defined string (if
            strings >= 2)

             Special string controls:
             \i italics toggle
                To make italics, use \i twice, around the text.
             \n 5 give number of sequences at coordinate 5.
                More than one \n can be used for different coordinates.
                If out of range, give maximum in symvec.
             \\ produce backslash
             \160 produce the Greek letter pi from the PostScript Symbol font.
                These fonts are listed on pages 270 to 273 of the "Red" book
                (see references, below).
             \r produce Rsequence
             \s produce standard deviation
             \d decimal places: must be followed immediately by the number of
                decimal places to use for the next \r or \s

             Example:
             \n 0 \i E. coli\i LexA binding sites
             will give the number of lexA sites at coordinate 0
             and make "E. coli" in italics.

             \d2 Rs = \r +/- \s bits
             will look like this:
             Rs = 5.72 +/- 3.46 bits

             For advanced users:
             HOW TO MAKE ITALICS IN YOUR STRINGS using PostScript
             To allow for italics, use a string like this:

38\) \( E. coli \) IT \(LexA binding sites

             This will make the words "E. coli" in
             Helvetica-BoldItalic font, but leave "38" and "LexA
             binding sites" in Helvetica-Bold.  See the technical
             notes for how this works.  The toggle form "\i" uses the
             same method, but simplifies it for the user.  This method
             allows one to create any PostScript commands.

    line 18+2*strings+1: 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 logo in cm.  To allow a
             sequence logo to be imbedded into another figure, its size must
             be defined in PostScript (with %%BoundingBox).  The basic logo
             fits within a rectangle, but the numbers along the bottom
             symbols and labels may be anywhere outside.  By setting these
             four numbers, the edges are defined.

    line 18+2*strings+2: ShowEnds: a single character
             d: show for DNA 5' and 3' on the logo
             p: show for protein N and C on the logo
             otherwise: nothing is shown.

    line 18+2*strings+3: formcontrol: a single character that determines
                the overall form control of the output.
                See discussion below and the examples.
             n: normallogo. standard sequence logo (or any other character)
             v: varlogo.  See discussion below for what this is.
             e: equallogo.  All stack heights are at the maximum.
                Of course this loses the useful data about the exact
                sequence conservation (measured in bits) at each
                position.
             r: rarelogo.  Plot (1-Pi) for each symbol instead of Pi.
                See discussion below.
             R: rareequallogo.  As with r, but equal stack heights.

             WARNING: To avoid missing important biological
             discoveries, BEFORE using the equallogo and rarelogo
             parameters read this page:

             https://alum.mit.edu/www/toms/logorecommendations.html

             To avoid a user thinking that a symbol is used when it is
             not, for r and R a '.' is plotted instead of the letter
             when Pi = 0.  This shows up as a black rectangle.


             This parameter was implemented on 2011 Mar 09.

    The remainder of the file is ignored and may contain comments.

   colors: Defines the color of each character printed.  Any number of lines
     that begin with an asterisk [*] can be used as comments to identify the
     file or portions of the file.  Put into the file one line for each
     character that is to have a color other than black.  The line must
     contain:

                    character red green blue

     The last three parameters are real values between 0 and 1 (inclusive).
     The values depend on the PostScript interpreter, but 0 means black and a
     value of 1 means the most bright.

     To assign the asterisk a color, proceed it with a backslash [as \*].

     To assign the backslash a color, proceed it with a backslash [as \\].

     If the file is empty, the logo is made in black and white and the lower
     half of the I-beam error bar is made white so that when it is inside the
     letters it is visible.

     To make any letter invisible, assign it any color less than zero, for
     example -1 -1 -1.  This is different than black, which is 0 0 0 and
     white which is 1 1 1.  The error bar will still be displayed.

     Each of the symbols A, C, G and T can represent either DNA or
     amino acids.  To distinguish between them, the lister program
     uses lower case in the colors file for DNA/RNA and upper case for
     amino acids.  This is now fully implemented in makelogo.  Note
     that the usual sequence logo for DNA has upper case letters. 
     This is done using the caps parameter.  New as of 2007 Mar 31.

   marks: an empty file means no marks are made.  Otherwise, a series of
     lines contain data that define marks to be placed on the output:

        symbol and kind: the first two characters on the line define
        the symbol and then how to draw the symbol.  The symbols are:

           c circle

           b box

           l line

           t triangle

           s square

           u Begin a user defined symbol.  Define a symbol yourself in
             PostScript.  The PostScript code may extend over several lines.
             The end of the code is given by the character "!" at the start
             of a line.  (The rest of the "!" containing line is ignored.)
             This allows one simply to insert some pre-tested PostScript
             between "u" and "!" lines of the marks file.  The code will be
             passed 4 coordinates and any other parameters given in the U
             line (defined below).

           U Call the user defined symbol.  The U must be followed by 4
             coordinates numbers: x1 y1 x2 y2.  The x1 and x2 are in bases,
             while y1 and y2 are in bits.  The remainder of the line is
             copied to the logo file, so you can have more parameters there.
             End the line with the name of one of your defined symbols.

           * a comment line

           % a comment line

        The drawing types are:
           s stroke
           f fill
           d dash

        If marksymbol is c, t or s, three more parameters are required:

           base coordinate: a real number that determines the center of the
              mark

           bits coordinate: a real number that determines the position of the
              mark in bits.

           scale: a positive real number in units of bases that is the
              diameter of the circle or the diameter of a circle that the
              equilateral triangle would be enscribed in.  For the square, it
              is the side.  By using units of bases, these marks
              automatically will fit between bases on the logo, as the
              charwidth is changed or other scaling is done.

        If marksymbol is b, l or U, 4 more parameters are required:
           base coordinate: a real number that determines end 1
           bits coordinate: a real number that determines end 1
           base coordinate: a real number that determines end 2
           bits coordinate: a real number that determines end 2
        The line is drawn from end 1 to end 2 while these ends define box
        diagonal.  Note that the center of a base is defined as an integer,
        so one must add 0.5 to base coordinates to put a boxes around a
        base.  You may make the user symbol use these coordinates however you
        want.

        ********************************************************************
        * The symbols MUST be in increasing order of position in the site! *
        ********************************************************************

        The symbols must be given in the order of their use in bases.  If
        symbols are not there, check the order.

        Since symbols are drawn concurrently with the logo letters, drawing a
        box or line symbol that has an end 2 to the left of the current
        position (which is end 1) will draw over the letters (because the
        letter was already drawn), while drawing to the right will draw under
        the letters (because the base is drawn over later).

        There is a special predefined user mark that allows one to toggle
        stacks between regular and outlined characters; see the outline
        parameter of makelogop.

   wave: Define a cosine wave over the graph.  Empty file means no cosine
       wave, otherwise the parameters of the wave are given one per line:

       extreme: char;  h or l, the extreme high or low point on the curve
         defined by the wavelocation and wavebit

       wavelocation: real; the location in bases of the extreme

       wavebit: real; the location in bits of the extreme

       waveamplitude: real; the amplitude of the wave in bits

       wavelength: real (positive); the wave length of the wave in bases

       dash: real; the size of dashes in cm.  Zero or negative means no
          dashes.

          If the first character on the line is 'd' then a
          new method of dash control is applied.  In this case there
          are three parameters:

          dashon: real; the size of dashes ON segment in cm.
             Zero or negative means no dashes.

          dashooff: real; the size of dashes OFF segment in cm.

          dashooffset: real; the offset for dashing.

          These parameters follow the PostScript Language Reference Manual,
          Second Edition, page 500.  Dashes start with the ON segment,
          followed by the OFF segment.  They are shifted by the offset,
          which is the amount into the dash cycle to start.

          NOTE:  The distances are defined along the length of the cosine,
          which is a function of the waveamplitude, bits per cm (barbits)
          and wavelength and bitsperbase.  For now it is simplest to
          empirically first determine the dashon and dashoff values that give
          repeats every wavelength, then set the dashoffset.

       thickness: real; thickness of the wave in cm.  Zero or negative means
          the value defaults to PostScript line thickness.

   logo: the output file, a PostScript program to display the logo.
       The last line of the file gives:
       Rsequence = area under the logo (bits)
       small sampling error (bits)
       range from, (bases)
       range to, (bases)
       information density = Rsequence /(two times bases in range)

   output: messages to the user

description

   The makelogo program generates a `sequence logo' for a set of aligned
   sequences.  A full description is in the documentation paper.  The input
   is an `symvec', or symbol-vector that contains the information at each
   position and the numbers of each symbol.  The output is in the graphics
   language PostScript.

   The program now indicates the small sample error in the logo by a small
   'I-beam' overlayed on the top of the logo.  Although the user may turn
   this off to make pretty logos, I strongly recommend use of it to avoid
   being fooled by small amounts of data.

********************************************************************************

   Making A Logo As Part of Another Figure
   ---------------------------------------

   The normal logo file is designed to stand by itself.  However, it is often
   desirable to incorporate the logo as part of another figure.  The
   difficulty is that the stand-alone logo PostScript program will erase the
   page (which wipes out any previous figure drawing) and show the page
   (which prints the page right after the logo).  To prevent these actions,
   the lines of PostScript code which do this have comments that contain the
   word REMOVE.  All you have to do is remove these lines and your logo will
   be able to fit into your figure.  In Unix this can be easily done by:

   grep -v REMOVE logo > logo.ps

   If you do this, then it is advisable to do the erasepage and the showpage
   yourself.  A convenient way to do this is to have several files that
   contain postscript commands, and to use a shell script to concatenate them
   together:

   cat start.ps logo.ps end.ps > myfigure.ps

   If you have a large number of logos together in one figure, you can reduce
   the size of the final figure by another trick.  Logo files begin with a
   header which is the same from one figure to the next assuming you don't
   change colors/letter combinations.  So the first logo in the figure must
   contain this header, but later ones don't really need it.  You can remove
   the header material by using the censor program:

   censor < logo.ps > logo.no.header.ps

   EXAMPLE:
   Suppose that you have two logo files, 1 and 2.  Then to join them, you can
   use the unix commands:

      grep -v REMOVE 1 > 3
      censor < 2 >> 3
      echo "showpage" >> 3

   The grep removes the REMOVE lines from file 1 and puts the rest into the
   start of file 3.  The censor removes the duplicate PostScript definitions
   from file 2 and appends the remainder to the end of 3.  Finally, the echo
   puts a 'showpage' command on the end of the file so that the printer will
   print the page (otherwise you won't get any printout).

********************************************************************************

   Playing with Ibeams
   -------------------
   Shmuel Pietrokovski (bppietro@dapsas1.weizmann.ac.il) suggested that the
   middle of the Ibeams be removable so that it doesn't get in the way of
   logos.  That is, a normal Ibeam looks like:

   -----
     |
     |
     |
     |
     |
     |
   -----

   This is sitting on the top of the sequence logo stack of letters.  This is
   obtained by setting the Ibeamfraction to 1.0.  Shmuel suggested that there
   be a parameter to remove the vertical part or to have it partway:

   -----
     |
     |


     |
     |
   -----

   This is obtained by setting the Ibeamfraction to 0.6.  Setting
   Ibeamfraction to -1.0, puts the vertical parts OUTSIDE the bars.  This way
   one can read one standard deviation of the stack and also have a mark at
   (for example) 2 standard deviations out at the tips of the thumb tacks:

     |
     |
   -----


   -----
     |
     |

********************************************************************************

   How do I disable the error bar?
   -------------------------------

   Set barbits negative.  If I were to do it again I'd separate the
   variables.  For example, -2 gives a height of 2 bits for the bar but would
   be no error bars.

********************************************************************************

   How do I label the residues every 5, for example 0, 5, 10, 15 ...
   -----------------------------------------------------------------

   There isn't a way to do this directly since I like having all positions
   labeled because it is less work for the reader to figure out where things
   are.  However, you can remove all numbering (set the numbering parameter
   to anything but 'n').  Then you can use the marks file to put numbers
   where you want.  See:  marks.lettering for a mechanism that I put together
   for this.  (There is a link from the 'See Also' section below.) You could
   even rotate the numbers if you know how to program PostScript.  If you get
   a nice working example, I can add it to my set.  If not, you *might*
   convince me to generate the marks file if you describe what you want and
   marks.lettering doesn't do it ;-).

********************************************************************************

   How do I set the default paper size (A4 or letter)?
   ---------------------------------------------------

   The simplest thing is to place the logo wherever you want on the page.
   You can set the box boundaries with the edgecontrol variables.

   You can also set the PostScript page size by changing the four constants:
   llx, lly, urx and ury.  This would require a recompile.  These numbers are
   in 'points', one point is 1/72 inch (I know, silly!) but you can convert
   precisely to cm by multiplying by 2.54/72.

********************************************************************************

   How do I make a logo that has several lines?
   --------------------------------------------

   If you are working with a protein or a very long DNA sequence, you might
   consider setting linesperpage to more than 1 and adjusting stacksperline
   and linemove accordingly.

********************************************************************************

   rarelogo:

   Sometimes one would like to examine the rare symbols.  This is one
   technique for doing so.  A parameter called 'formcontrol' is set to
   'r' to use this.

   In a conventional logo, for the bases A, C, G, T the heights are
   set to the conservation.  Call this "1" so that A+C+G+T = 1.

   A "rare logo" graphs:

   (1-A)
   (1-C)
   (1-G)
   (1-T)

   The sum of these is 4 - (A+C+G+T) = 3.  That's a bit strange, but ok!
   It says that you plot each symbol with a height: 
 
   conservation*(1-Pi)/(M-1)

   Where M is the number of symbols in the alphabet.

   varlogo:  If the first letter is 'v' then the makelogo program will
   produce a 'varlogo'.  This method was invented by Peter Shenkin
   (Shenkin.Mastrandrea1991).  In a regular sequence logo the vertical
   scale is the information content.  However in some systems, as in
   the immunoglobulin variable regions, one is not interested in the
   conservation, but rather the degree of variability.  This is best
   expressed as the uncertainty Hafter(l) rather than the information
   R(l) = Hbefore - Hafter(l) (where 'l' is the position in the
   sequence alignment).  Basically, it "turns over" the curve.  This
   is also implemented in alpro.

********************************************************************************

@article{Shenkin.Mastrandrea1991,
author = "P. S. Shenkin
 and B. Erman
 and L. D. Mastrandrea",
title = "{Information-theoretical entropy as a measure of sequence
variability}",
journal = "Proteins",
volume = "11",
pages = "297--313",
pmid = "1758884",
year = "1991"}

see also

   {Example sequence logos:}
   https://alum.mit.edu/www/toms/icons/lexa-logo.gif
   https://alum.mit.edu/www/toms/icons/donor.pure.gif

   {A Gallery of Sequence Logos:}
   https://alum.mit.edu/www/toms/sequencelogo.html

   {Glossary definition of Sequence Logo:}
   https://alum.mit.edu/www/toms/glossary.html#sequence_logo

   {-----------------------}

   {FORM CONTROL FOR SEQUENCE LOGOS}
   {controlled by parameter formcontrol}

   {WARNING: To avoid missing important biological discoveries, BEFORE}
   {using the equallogo and rarelogo parameters read this:}

   https://alum.mit.edu/www/toms/logorecommendations.html

   {Normal logo (normallogo):}
   {Note: the sine wavelength is 3.6 amino acids, corresponding to an alpha helix.}
   https://alum.mit.edu/www/toms/makelogo/normallogo.gif

   {Variable logo (varlogo):}
   {Plot Hafter(l) instead of R(l).}
   https://alum.mit.edu/www/toms/makelogo/varlogo.gif

   {Equal logo (equallogo):}
   {Equal stack heights. Note that sequence conservation data is lost.}
   https://alum.mit.edu/www/toms/makelogo/equallogo.gif
   SEE WARNING ABOVE!

   {Rare logo: (rarelogo):}
   {Plot 1-Pi instead of Pi.  Normal stack heights}
   https://alum.mit.edu/www/toms/makelogo/rarelogo.gif

   {Rare-Equal logo: (rareequallogo):}
   {Plot 1-Pi instead of Pi, equal stack heights.}
   https://alum.mit.edu/www/toms/makelogo/rareequallogo.gif
   SEE WARNING ABOVE!

   {-----------------------}

   {FULL WORKING EXAMPLE
    This is a full test of makelogo.

   1. obtain these files:}

   lambdacicro.colors      lambdacicro.makelogop   lambdacicro.symvec
   lambdacicro-logo.ps     lambdacicro.marks       lambdacicro.wave

   {2. Except for the lambdacicro-logo.ps file,
    copy these to files without the 'lambdacicro.'.
    3. Run makelogo.
    4. Except for the version number, makelogo should create a logo file
       identical to lambdacicro-logo.ps.

    Unix commands for doing the test are:

    cp lambdacicro.colors    colors    
    cp lambdacicro.makelogop makelogop
    cp lambdacicro.symvec    symvec
    cp lambdacicro.marks     marks
    cp lambdacicro.wave      wave
    makelogo
    diff lambdacicro-logo.ps logo

    }

   {-----------------------}

   {Related programs:}

   {There are several ways to get the symvec file, this is described in:}
   https://alum.mit.edu/www/toms/logoprograms.html

   {1. The Alpro route to making logos:} alpro.p

   {2. The Delila route to making logos:}
   dbbk.p, catal.p, delila.p, alist.p, encode.p, rseq.p, dalvec.p

   {3. A program that creates a symvec from a list of words is:}
   alword.p

   {-----------------------}

   {To PRINT LOGOS see:}
   https://alum.mit.edu/www/toms/postscript.html

   {-----------------------}

   {Other related programs:}
   rsgra.p, sites.p, censor.p, rav.p

   {Example input files:}
   symvec, makelogop, colors, wave, marks

   {Some demonstration input files:}
   symvec.demo, colors.demo, makelogop.demo, wave.demo, marks.demo
   {Resulting output file:}
   logo.demo

   {Example output files, in postscript:}
   logo

   {Other examples and useful control files:}
   colors.protein
   marks.arrow
   marks.ellipse
   marks.lettering
   marks.plusminus
   marks.symbols
   marks.userdefined

author

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

examples
   makelogop parameters:

-15 2      FROM to TO range to make the logo over
1          sequence coordinate before which to put a bar on the logo
15 2       (xcorner, ycorner) lower left hand corner of the logo (in cm)
90         rotation: angle to rotate the graph
1.0        charwidth: (real, > 0) the width of the logo characters, in cm
10 0.1     barheight, barwidth: (real, > 0) height of vertical bar, in cm
2          barbits: (real) height of the vertical bar, in bits; < 0: no I-beam
no bars    barends: if 'b' put bars before and after each line
show       showingbox: if 's' show a dashed box around each character; f = fill
no outline outline: if 'o' make each character as an outline
100        stacksperline: number of character stacks per line output
1          linesperpage: number of lines per page output
1.1        linemove: line separation relative to the barheight
numbers    numbering: if the first letter is 'n' then each stack is numbered
1          shrinking: factor by which to shrink characters inside dashed box
2          strings: the number of user defined strings to follow
2 14 1     coordinates of the first string (in cm)
First TITLE
3 13 1     coordinates of the second string (in cm)
SECOND TITLE
n 2 1 2 1  edgecontrol (p=page), edgeleft, edgeright, edgelow, edgehigh in cm
d          d: 5' 3'; p: N C; else: nothing shown on ends 

makelogop.dna: parameters for the makelogo program, version 8.31 or higher

   colors:
* Color scheme for logos of DNA (for the makelogo program).
* color order is red-green-blue
*
* green:
A 0 1 0
a 0 1 0
*
* blue:
C 0 0 1
c 0 0 1
*
* red:
T 1 0 0
t 1 0 0
*
* orange:
G 1 0.7 0
g 1 0.7 0

   wave:
l        extreme: char; h or l, the high or low extreme to be defined
2        wavelocation: real; the location in bases of the extreme
1.0      wavebit: real; the location in bits of the extreme
0.5      waveamplitude: real; the amplitude of the wave in bits
10.4     wavelength: real; the wave length of the wave in bases
0        dash: real; the size of dashes in cm.  dash <= 0 means no dashes
0.1      thickness: real; thickness of the wave in cm. <=0: default.

   marks:

* example marks file for makelogo 8.06 and higher
*
* square stroked, filled and dotted:
ss -2 -0.40 0.5
sf -1 -0.30 0.5
sd  0 -0.20 0.5
*
* circle stroked, filled and dotted:
cs  1 -0.40 0.5
cf  2 -0.30 0.5
cd  3 -0.20 0.5
*
* triangle stroked, filled and dotted:
ts  4 -0.40 0.5
tf  5 -0.30 0.5
td  6 -0.20 0.5
*
* box stroked, filled and dotted base to base:
bs  7 -0.40  8 0
bf  8 -0.30  9 0
bd  9 -0.20 10 0
*
* line stroked, filled and dotted base to base:
ls 10 -0.40 11 0
lf 11 -0.30 12 0
ld 12 -0.20 13 0
*
* box stroked, filled and dotted, around bases:
bs 13.5 -0.40 14.5 0
bf 14.5 -0.30 15.5 0
bd 15.5 -0.20 16.5 0
*
* line stroked, filled and dotted, around bases:
ls 16.5 -0.40 17.5 0
lf 17.5 -0.30 18.5 0
ld 18.5 -0.20 19.5 0

  A test symvec is provided with the program, file 'symvec.demo', to be run
  with 'colors.demo' and 'makelogop.demo'.

documentation

   Description of Logos:
@article{Schneider.Stephens1990,
author = "T. D. Schneider
 and R. M. Stephens",
title = "Sequence Logos: A New Way to Display Consensus Sequences",
journal = "Nucleic Acids Res.",
volume = "18",
pages = "6097--6100",
pmid = "2172928",
pmcid = "PMC332411",
note = "\htmladdnormallink
{https://alum.mit.edu/www/toms/papers/logopaper/}
{https://alum.mit.edu/www/toms/papers/logopaper/}",
year = "1990"}

   Use of wave:
@article{Papp.Schneider1993,
author = "P. P. Papp
 and D. K. Chattoraj
 and T. D. Schneider",
title = "{Information analysis of sequences that bind the replication
initiator RepA}",
journal = "J. Mol. Biol.",
volume = "233",
pages = "219--230",
pmid = "8377199",
comment = "Cover of 233, number 2!",
year = "1993"}

   Dirty DNA synthesis experiments:
@article{Schneider.Stormo1989,
author = "T. D. Schneider
 and G. D. Stormo",
title = "{Excess information at bacteriophage T7 genomic promoters
detected by a random cloning technique}",
journal = "Nucleic Acids Res.",
volume = "17",
pages = "659--674",
pmid = "2915926",
pmcid = "PMC331610",
year = "1989"}

   The Blue Book:
@book{PostScriptTutorial1985,
author = "{Adobe Systems Incorporated}",
title = "PostScript Language Tutorial and Cookbook",
publisher = "Addison-Wesley Publishing Company",
address = "Reading, Massachusetts",
callnumber = "QA76.73.P67P68",
isbn = "0-201-10179-3",
year = "1985"}

   The Red Book:
@book{PostScriptManual1985,
author = "{Adobe Systems Incorporated}",
title = "PostScript Language Reference Manual",
publisher = "Addison-Wesley Publishing Company",
address = "Reading, Massachusetts",
callnumber = "QA76.73.P67P67",
isbn = "0-201-10174-2",
year = "1985"}

bugs
   Some chi-logo (upside down characters) do not display on OpenWindows, but
   do print ok on the Apple LaserWriter IIntx.  The reason is completely
   obscure.

   A bug in NeWS 1.1 is that characters that are scaled too small are forced
   to be big.  This messes up the logo and can be confusing.  Another bug in
   NeWS 1.1 prevents one from using the outline, but the dashed boxes will
   show up.  Sometimes displaying a logo in NeWS 1.1 on a Sun 4 will cause an
   'illegal instruction', after which one is thrown completely off the
   computer.  The source of this is not known, since it is not repeatable.
   The first two bugs are resolved under OpenWindows 2; the third has not
   been observed.  These NeWS bugs do not apply to the Apple LaserWriter
   IIntx, which prints everything correctly.

   * MISSING LOGO LETTER PROBLEM
   The OpenWindows PostScript on a Sun workstation will mess up displaying a
   stack of letters if the vertical movement is too small.  The result is
   that the letters above that point are missing.  This occurs if there is a
   highly conserved base and very few other bases.  The result is a huge gap
   where the highly conserved base should be.  Other printers do fine, so
   this is a problem with the Sun implementation of PostScript (will they
   ever get it right???).  If you don't have this window system, set the
   constant gooddisplay to true.  If you do want the logos to show up
   properly on the screen, use false.  Unfortunately, this will mean that the
   vertical translation for the small letters won't be done, so the display
   will be very slightly wrong.

   * The freeware program Ghostview will sometimes refuse to print some
   bases, but they come out just fine on many printers.

   *******************************************************************

   * Eric Miller (esm@unity.ncsu.eduk, http://www.mbio.ncsu.edu/esm) pointed
   out (2000 Dec 15):

   > Aesthetically, the error bars at the bottom of the logo (little to no
   > information regions) obscure the base coordinate line.

   Yes that's bothered me at times also.

   > For a given logo, the error bars are / appear the same length, probably
   > as a function of the number of sequences present in the alignment, since
   > each position is represented in each sequence.

   That's correct.

   > It would be preferable to have the logo error bar in a single location
   > (since they are the same),

   No they aren't all the same.  The delila system handles blanks, where no
   sequence is known or reported.  So error bars tend to be bigger away from
   the center of the logo where there are fewer sequences.  Some examples are
   in the Gallery, especially the 8 E. coli sequence logos.

   > maybe off any letter of the sequence (above a specified coordinate
   > position, at a specified bit height), or just on the high part of the
   > logo.  I need to check the makelogop to see if the error bars can be
   > removed or modified.

   One can remove the bars, though of course one goes blind at that point.
   Moving them is an interesting idea.  Of course the problem is in the cases
   where there is low information content, so wouldn't work.  If one had a
   lower bound, then explaining it to people would be complex - one's eye
   would see it more than the background!  Also, one could not judge the
   background against the bars.  One solution might be to block the bar below
   zero, but then I'm worried that partial bars may be misinterpreted.  So
   you raise a good issue but I don't know a good solution.  Fortunately it
   is for the most part aesthetic as you say - one can figure out the
   numbering.

   *******************************************************************

technical notes

   * HERE'S HOW ITALIC STRINGS WORK.  User defined strings have to be
   rendered into PostScript.  To indicate that a region of the string is to
   be done in italics, one must gain access to the PostScript machinery.  For
   example:

38\) \( E. coli \) IT \(LexA binding sites (extra parenthesis)

   The first "\)" after the "38" switches to the PostScript interpreter. The
   backslash "\" is used as an "escape" character, telling makelogo that the
   following character is to be interpreted as PostScript.  (Otherwise
   makelogo would protect the character and you would just get a
   parenthesis.) Likewise, the string

\( E. coli \)

   is interpreted as a PostScript string.  At that point there will be
   two strings on the stack, the (38) and the "( E. coli )".  There is
   a special function defined in makelogo called IT.  IT takes these
   two strings and shows the first in Helvetica-Bold and the second in
   Helvetica-BoldItalic.  After that we must return to normal typing,
   and this is done with "\(" just before "LexA".  The general form
   for using PostScript commands is therefore

\) postscriptstuff \(

   That is, the parenthesis always match backwards.  The code (procedure
   postscriptstring) is curious and interesting because it starts with a
   string like this:

38\) \( E. coli \) IT \(LexA binding sites (extra parenthesis)

   and converts it to the following valid PostScript:

(38) ( E. coli ) IT (LexA binding sites \(extra parenthesis\))

   The escape character by the user is removed from parenthesis, while
   unprotected parenthesis get escape characters!

   Why not let the user type raw postscript?  Because they would have to
   remember to type a \ in front of various characters, and this would often
   lead to programs that would bomb.

   Note that one can define ANY function one would like by this means!

   * Unfortunately PostScript fonts are not exactly the same height.  Thus if
   A and T are the standard, then C and G hang above and below the line.
   This has been solved in this version of makelogo.  As a consequence, the
   user never need to determine any character sizes empirically, and the
   logos should work on any PostScript printer.

   Special thanks go to the following people for their help in solving this
   problem:

   Kevin Andresen [kevina@apple.com]
   "The problem facing you is that, while the PostScript language is more or
   less standard, the font shapes depend on the designer, type vendor, or
   language implementation.  The fonts used in NeWS are not exactly the same
   as those from Adobe, which are not the same as those from Bitstream, which
   are not the same as the original lead type, etc.  (This is an
   industry-wide issue.)  One way to compensate for this in PostScript is to
   use the charpath and pathbbox operators and scale appropriately."

   He provided a program, which I then rewrote and generalized.  That version
   almost worked, but not quite.  This was solved by:

   finlay@Eng.Sun.COM (John Finlay) who said:
   "It would appear that the calculation of the pathbbox for characters
   varies with the scale of the characters (I don't know why exactly but
   would speculate that there's probably some weirdness with the font hints
   and scaling).  I modified your postscript to iterate once on the size and
   recalculate the pathbbox at the scaled size.  Seems to printout OK (inside
   the boxes) on a LWI, LWII and in NeWS2.0 (though NeWS still seems to get
   the wide slightly wrong)."

   shiva@well.sf.ca.us (Kenneth Porter) was also involved and actively
   interested.  My apologies if I have forgotten someone else who
   contributed.

   The letter I and the vertical bar (|) are treated specially since
   in the Helvetica-Bold font they are rectangles and would completely
   fill the character space.  In addition, the letter I is centered by
   makelogo.

   * Thanks go to Joe Mack for suggesting numbering and titles (strings) and
   to Pete Lemkin and Wojciech Kasprzak for pointing out that the shrink
   option would be helpful.  Thanks to Jeff Haemer for pointing out that the
   PostScript program should begin with '%!', and for suggesting that the
   string fonts should be different from the logos themselves.

   * As of version 8.12, makelogo produces encpsulated PostScript.  This
   allows the logo to be more safely imbedded in other figures.  The
   BoundingBox, which defines the region a figure resides on a page, is
   computed from the basic size of the logo.  The width is computed from the
   charwidth and stacksperline.  The height is computed from barheight,
   linesperpage and linemove.  The linemove parameter is used only if
   linesperpage is more than 1.  The edge parameters are then added around
   all edges.  This allows the numbering and labels to be inside the
   BoundingBox.  The figure can be rotated by -90 or +90 degrees.  Other
   rotations result in a BoundingBox that is page-sized.  Note that rotations
   can place much of the logo outside of the page.  The bounding box will not
   show parts outside of the page, so this can be confusing.  To see roughly
   where the logo will appear on the page, use -89 or +89 angles.

   * Constant centertrigger determines the value of the base position of a
   string at which the string will be centered.

   * 2006 Oct 25.  Very small values of Rs(l) = rsl < 0.00005, cause
   ghostview to crash.  Changing rsl would alter the sum, so that is
   not a solution.  The solution is to restrict the minimum stack size
   drawn to the constant minimumStackSize.

   * 2018 Jul 25.  Very small character sizes cause a 'squash-spray'
   effect.  The effect is a thin colored line extending to the right
   of the sequence logo (a spray), usually at zero bits corresponding
   to a letter whose height is very small (squash).  That is, the
   letter is squashed and sprayed to the right.  This did not happen
   with MacOS some time ago but more recently it has occured with both
   Skim and Adobe viewers.  Experimenting with calls to numchar
   suggested that it occurs when the charheight is less than the
   constant squashspray in points.  So the code now simply does not
   show the character if the height is below that value.  It appears
   that squashspray is best to be set to 1 point.  When the effect
   occurs, the squashed near-zero height letters are displayed anyway
   as "junk" along the bottom of the logo since they have been sorted
   to be small.  When they are removed, the larger letters do not move
   vertically , but the "junk" disappears.  This was confirmed using
   the flicker technique: https://alum.mit.edu/www/toms/flicker.html
   The example used to solve this bug is show by this flicker:
   https://alum.mit.edu/www/toms/images/squashspray.gif

   * 2018 Jul 26.  squashspray becomes a hidden variable next to
   charwidth.  The default (squashspraydefault) is 1 point but this
   doesn't always work for unknown reasons.

   * 2018 Aug 08.  When a character is smaller than squashspray it
   will be drawn as a filled rectangle instead of being invisible. 
   Users won't notice this much since the rectagle will generally be
   small.

*)
(* end module describe.makelogo *)

(* begin module makelogo.const *)

   infofield = 8; (* size of field for printing information in bits *)
   infodecim = 5; (* number of decimal places for printing information *)

   nfield = 4; (* size of field for printing n, the number of sites *)
   mapmax = 26; (* the maximum number of symbols that can be sorted *)

   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) *)
   pnum = 100000; (* 10^pdec for testing when something will round to zero *)

   protecting = true; (* protect the user against PostScript requirements
      in user defined strings.  *)

   gooddisplay = false;  (* see technical notes for explanation. *)

   (* bounding box definitions: *)
   (* NOTE: these values were reported by the inkjet to be real numbers.
      HOWEVER the definition in the red book (p. 284) explicitly states
      that they must be integers, so before putting out the bounding
      box, they are rounded. *)

   (* The following bounding box is for the Canon Color Laser Copier 800S. *)
   llx =  10.08; (* lower left x *)
   lly =   8.91; (* lower left y *)
   urx = 588.06; (* upper left x *)
   ury = 779.85; (* upper left y *)

{
   (* the following bounding box is for the inkjet Phaser 140 *)
   llx =  14.4; (* lower left x *)
   lly =  28.9; (* lower left y *)
   urx = 596.8; (* upper left x *)
   ury = 777.7; (* upper left y *)
}

   edgemargindefault = 2; (* the default amount of edge to add (cm) *)

   centertrigger = -1000; (* If the location of a string is smaller
      than this number, the string will be centered instead *)

   outlinethinness = 32; (* The factor to divide charwidth by to get
      twice the thickness of lines when doing character outlining. *)

   subticsBigdefault   =  2; (* default number of Big subtics on bars *)
   subticsSmalldefault = 10; (* default number of Small subtics on bars *)

   (* 2006 Oct 25.  Very small values of Rs(l) = rsl cause ghostview
      to crash.  The solution is to restrict the stack size: *)
   minimumStackSize = 13;
{mmm}

   (* 2018 Jul 25. squash-spray. *)
   squashspraydefault = 1.00; (* default for squashspray,
        the minimum size letter to display in points *)

(* end module makelogo.const *)

(* begin module interact.const *)
(* begin module string.const *)
      maxstring = 150; (* the maximum string *)
(* end module string.const version = 4.51; (@ of prgmod.p 2000 Nov 1 *)
(* end module interact.const version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

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.51; (@ of prgmod.p 2000 Nov 1 *)
(* end module interact.type version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module rsgra.type *)
(* begin module wave.type *)
      waveptr = ^waveparam; (* to link several wave definitions together *)
      waveparam = record (* parameters to define a cosine wave *)
         (* define a cosine wave: *)
         extreme: char; (* h or l, the high or low extreme to be defined *)
         wavelocation: real; (* the location in bases of the extreme *)
         wavebit: real; (* the location in bits of the extreme *)
         waveamplitude: real; (* the amplitude of the wave in bits *)
         wavelength: real; (* the wave length of the wave in bases *)
{ 2000 Nov 1.  This is difficult because the length of a curve is not
simply multiplied by a scale factor.
         BASEdashon: real; (* dashon interval in bases *)
         BASEdashoff: real; (* dashon interval in bases *)
         BASEdashoffset: real; (* dashon interval in bases *)
}
         dashon: real; (* the size of on dashes in cm.
                          dashon <= 0 means no dashes *)
         dashoff: real; (* the size of on dashes in cm *)
         dashoffset: real; (* the size of off dashes in cm *)
         thickness: real; (* thickness of the wave in cm.  <= 0 means default *)
         next: waveptr; (* the next wave *)
      end;
(* end module wave.type version = 4.51; (@ of prgmod.p 2000 Nov 1 *)
(* end module rsgra.type version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.type *)
   (* types for sorting the symbols *)
   position = 0..mapmax;
   place = record
      b: char; (* the symbol *)
      n: integer (* the number of symbols *)
   end;

   (* type for making a list of strings *)
   stringsptr = ^strings;
   strings = record
      astring: string;
      x: real; (* x coordinate of the string *)
      y: real; (* y coordinate of the string *)
      s: real; (* scale factor *)
      next: stringsptr
   end;

parameters = record (* parameters that control the sequence logo *)
   Ibeamfraction: real; (* The fraction of the Ibeam to draw.  When it is 1,
      the Ibeam is normal.  When it is zero, no vertical line is drawn. At 0.1,
      only 10 percent of the top and bottom parts of the Ibeam are drawn. *)
   bar: integer; (* location before which to print the bar *)
   barbits: real; (* (real) height of the vertical bar, in bits.  If negative,
      then the I-beam will not be displayed *)
   barends: char; (* put a bar before and after each line,
      b: both left and right; r right only; l left only *)
   barheight: real; (* (real, > 0) height of the vertical bar, in centimeters *)
   barwidth: real; (* (real, > 0) width of the vertical bar, in centimeters *)
   caps: boolean; (* if true, capitalize the logo *)
   charwidth: real; (* (real, > 0) the width of the logo characters, in cm *)
   edgecontrol: char; (* if 'p' then use page instead of edges *)
   edgeleft, edgeright, edgelow, edgehigh: real; (* edges around the logo *)
   highest: integer; (* the coordinate of the highest symbol to graph in logo *)
   linemove: real; (* line separation relative to the barheight *)
   linesperpage: integer; (* the number of lines per page output *)
   lowest: integer; (* the coordinate of the lowest symbol to graph in logo *)
   numbering: boolean; (* if true, numbers are made below the logo *)
   outline: boolean; (* if true, characters are made in outline *)
   rotation: real; (* angle in degrees to rotate the figure *)
   showingbox: char; (* s = show a box around each character, f = fill *)
   ShowEnds: char; (* d: 5' 3'; p: N C; else: nothing shown on ends *)
   shrink: real; (* the factor by which to shrink symbols *)
   shrinking: boolean; (* whether or not to shrink *)
   squashspray: real; (* minimum size letter to display in points *)
   stacksperline: integer; (* the number of characters per line output *)
   subticsBig: integer; (* the number BIG subtics per bit *)
   subticsSmall: integer; (* the number SMALL subtics per bit *)
   thestrings: stringsptr; (* set of user defined strings *)
   ticcommand: char; (* if 't' then create subtics *)
   xcorner: real; (* the lower left corner of the x-axis on the paper (cm) *)
   ycorner: real; (* the lower left corner of the y-axis on the paper (cm) *)

   HalfWhiteIbeam: boolean; (* true means that no colors are defined in the
      colors so the I-beam error bar is made white when inside the letters *)
   wp: waveptr; (* wave parameters that define cosine waves *)

   (* other global-like variables *)
   cmperbit: real; (* conversion of bits to centimeters *)
   symbols: integer; (* number of symbols possible (from symvec) *)

   formcontrol: char; (* control the overall form of the logo graphic
             n: standard sequence logo
             v: varlogo
             e: equallogo
             r: rarelogo
             R: rareequallogo
             *)
   stackheight: real; (* height of the stack *)
   symbolheight: real; (* height of a symbol in the stack *)
   showletter: boolean; (* show the letter? *)
end;

(* end module makelogo.type *)

var
(* begin module makelogo.var *)
   symvec, (* output of alpro program *)
   makelogop, (* parameters to control the program *)
   colors, (* color definitions *)
   marks, (* locations of marks on the logo *)
   wave, (* cosine wave definition *)
   logo: (* output of program *)
      text;

   (* the storage for sorting the symbols *)
   map : packed array[1..mapmax] of place;

(* end module makelogo.var *)

(* begin module halt *)
procedure halt;
(* stop the program.  the procedure performs a goto to the end of the
   program.  you must have a label:
      label 1;
   declared, and also the end of the program must have this label:
      1: end.
   examples are in the module libraries.
   this is the only goto in the delila system. *)
begin
      writeln(output,' program halt.');
      goto 1
end;
(* end module halt version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module capitalize *)
function capitalize(c: char): char; 
(* convert the character c to upper case *) 
var 
   n: integer; (* c is the n'th letter of the alphabet *)
begin 
   n := ord(c); 
   if (n >= ord('a')) and 
      (n <= ord('z'))   
   then c := chr( n - ord('a') + ord('A'));
   capitalize := c
end; 
(* end module capitalize version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module skipblanks *)
procedure skipblanks(var thefile: text);
(* skip over blanks until a non-blank, or end of line, is found *)
begin
      while (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 (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 = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module interact.clearstring *)
(* begin module clearstring *)
procedure clearstring(var ribbon: string);
(* empty the string *)
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; (* 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. *)
begin (* initializestring *)
   clearstring(ribbon);
   ribbon.next := nil;
end; (* initializestring *)
(* end module clearstring version = 4.51; (@ of prgmod.p 2000 Nov 1 *)
(* end module interact.clearstring version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module interact.getstring *)
procedure getstring(var afile: text; var buffer: string;
                    var gotten: boolean);
(* get a line (as a string) from a file not using string calls.  this lets
one obtain lines from a file without interactive prompts *)
var   index: integer; (* of buffer *)
begin (* getstring *)
      clearstring(buffer);
      if eof(afile)
      then gotten := false
      else begin
         index := 0;
         while (not eoln(afile)) and (index < maxstring) do begin
            index := succ(index);
            read(afile, buffer.letters[index])
         end;
         if not eoln(afile) then begin
            writeln(output, ' getstring: a line exceeds maximum string size (',
                            maxstring:1,')');
            halt
         end;
         buffer.length := index;
         buffer.current := 1;
         readln(afile);
         gotten := true
      end
end; (* getstring *)
(* end module interact.getstring version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module interact.writestring *)
(* 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 = 4.51; (@ of prgmod.p 2000 Nov 1 *)
(* end module interact.writestring version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module copystring *)
procedure copystring(a: string; var b: string);
(* copy string a to b *)
var l: integer; (* index to the string *)
begin
   b.length := a.length;
   for l := 1 to a.length do b.letters[l] := a.letters[l]
end;
(* end module copystring version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

function lessthan(a, b: position): boolean;
(* see quicksort *)
begin
   (* the abs function makes sure upside down
      letters are still sorted the right way! *)
   lessthan:=(abs(map[a].n) < abs(map[b].n))
end;

procedure swap(a,b: position);
(* see quicksort *)
var
   holdb: char;
   holdn: integer;
begin
   holdn:=map[a].n;
   map[a].n:=map[b].n;
   map[b].n:=holdn;

   holdb:=map[a].b;
   map[a].b:=map[b].b;
   map[b].b:=holdb;

(*;write(output,'a=',a:1,', b=',b:1); print (@ for testing *)
end;

(* begin module quicksort *)

procedure quicksort(left, right: position);
(* quick sort a list between positions left and right, into ascending order.
   a position is simply a scalar of the form 0..max.
   the array to be sorted is dimensioned 1..max.
(the difference in the ranges is important to the correct operation
of the sort...)
   two external routines are used:
      function lessthan(a, b: position): boolean is a generalized test for
          value-at-a < value-at-b.
      procedure swap(a, b: position) switches the items at positions a and b.
   since these routines are external, the procedure is general.

   this procedure taken from the book
   'algorithms + data structures = programs' by niklaus wirth,
   prentice-hall, inc., englewood cliffs, n.j.(1976), pp. 76-82 *)
var
      lower, upper: position; (* the positions looked at currently *)
      center: position; (* the rough center of the region being sorted *)
begin
      lower  := left;
      center := (left + right) div 2;
      upper  := right;

      repeat
         while lessthan(lower, center) do lower := succ(lower);
         while lessthan(center, upper) do upper := pred(upper);

         if lower <= upper then begin
            (* keep track of the center through the map: *)
                 if lower = center then center:=upper
            else if upper = center then center:=lower;
            swap(lower, upper);
            lower := succ(lower);
            upper := pred(upper)
         end
      until lower > upper;

      if  left < upper then quicksort(left,  upper);
      if lower < right then quicksort(lower, right)
end;

(* end module quicksort version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* 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 = 4.51; (@ of prgmod.p 2000 Nov 1 *)

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

(* begin module readwaveparameters *)
procedure readawaveparameter(var afile: text; var wp: waveparam);
{
                                 cmperbase, cmperbit: real);
}
(* Read one wave parameter from a file. *)
{
2000 Nov 1:  The following experimental code is not implemented:
See the coscurve program
(https://alum.mit.edu/www/toms/delila/coscurve.html) for details
about the conversion from bases to cm.  The code now requires
cm per base and cmperbit.
const
   lover2pi = 1.2160067233; (* L/2pi for L being the length of
       the cosine function from 0 to 2pi *)
var
   multiplier: real; (* factor to multiply by to convert from bases to cm. *)
}
begin
   readln(afile,wp.extreme);
   readln(afile,wp.wavelocation);
   readln(afile,wp.wavebit);
   readln(afile,wp.waveamplitude);
   readln(afile,wp.wavelength);
   if wp.wavelength <= 0.0 then begin
      writeln(output,'wave parameters: wavelength must be positive');
      halt
   end;
   (* one may skip the dash and thickness parameters
      of the last wave definition.  This allows
      backwards compatability, but should not be
      used in general. *)
   if eof(afile)
   then begin
      wp.dashon := 0;
      wp.dashoff := 0;
      wp.dashoffset := 0;
      wp.thickness := 0
   end
   else begin
      (* implement new method to read dash information
         without breaking previous wave parameter files *)
      if afile^ <> 'd'
      then begin (* default to old method *)
         readln(afile,wp.dashon);
         wp.dashoff := wp.dashon;
         wp.dashoffset := 0;
      end
      else begin
         get(afile); (* skip the 'd' *)
         (* reading the parameters directly in cm would require
            that the user compute or guess the values.
            So read in as bases and compute cm.
            Unfortunately the length of a curve is not the simple
            scale factor.  Make the user guess for now.
         *)
         readln(afile,wp.dashon, wp.dashoff, wp.dashoffset)

{
experimental code to account for actual wave length:
         readln(afile, wp.BASEdashon, wp.BASEdashoff, wp.BASEdashoffset);
         multiplier    := 1;
         multiplier    := lover2pi
 * wp.waveamplitude (* in bits *)
 * cmperbit (* converts to cm *)
 / wp.wavelength (* 10.6 bp/turn *)
* cmperbase
;
multiplier    := lover2pi;
multiplier    := 1.0;
multiplier    := 1.0/lover2pi;
         multiplier := lover2pi
                       * wp.waveamplitude (* in bits *)
                       * cmperbit (* converts to cm *)
                       * wp.wavelength (* 10.6 bp/turn *)
                       * cmperbase;
         multiplier := 1.0
         wp.dashon     := multiplier * wp.BASEdashon;
         wp.dashoff    := multiplier * wp.BASEdashoff;
         wp.dashoffset := multiplier * wp.BASEdashoffset;
with wp do begin
   writeln(output, 'cmperbase  = ',cmperbase:5:2);
   writeln(output, 'cmperbit   = ',cmperbit:5:2);
   writeln(output, 'dashon     = ',dashon:5:2);
   writeln(output, 'dashoff    = ',dashoff:5:2);
   writeln(output, 'dashoffset = ',dashoffset:5:2);
   writeln(output, 'waveamplitude   = ',wp.waveamplitude:5:2);
   writeln(output, 'wavelength      = ',wp.wavelength:5:2);
end;
}

      end;
      if eof(afile)
      then wp.thickness := 0
      else readln(afile,wp.thickness);
   end;
end;

procedure readwaveparameters(var afile: text; var w: waveptr);
{
                                 cmperbase, cmperbit: real);
}
(* read from afile the wave parameters w.  The routine is done either at end
of file, when a period ('.') appears or at a blank line.  This makes it
compatable with different reading mechanisms. *)
var
   done: boolean; (* done reading *)
   morethanone: boolean; (* more than one wave? *)
   p: waveptr; (* one of the definitions of a cosine wave *)
procedure waystoend;
(* if end of file, a blank line or a period, consider the job done *)
var
   clear: boolean; (* not eof, so clear to test for comment *)
begin
   if eof(afile) then done := true;
   clear := false;
   if not done (* skip any number of comments *)
   then while (not clear) and (not done) do begin
      if eof(afile) then begin
         done := true;
         clear := true;
      end
      else if afile^ = '*'
           then readln(afile)
           else clear := true
   end;
   if not done then if eoln(afile) then done := true;
   if not done then if afile^='.' then begin
      readln(afile);
      done := true;
   end;
end;
begin
   done := false;
   morethanone := false;
   w := nil;
   waystoend;
   if not done then begin
      new(w);
      p := w;
      while not done do begin
         waystoend;
         if done
         then p^.next := nil
         else begin
            if afile^='*'
            then readln(afile) (* skip any number of comments *)
            else begin
               if morethanone then begin
                  new(p^.next);
                  p := p^.next
               end;
{
               readawaveparameter(afile, p^, cmperbase, cmperbit);
}
               readawaveparameter(afile, p^);
               (* if we ever come back again there will be more than one: *)
               morethanone := true;
            end
         end
      end
   end
   else w := nil;
end;
(* end module readwaveparameters version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

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

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

(* 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 = 4.51; (@ of prgmod.p 2000 Nov 1 *)
 
(* 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 = 4.51; (@ of prgmod.p 2000 Nov 1 *)

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

(* 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 = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* 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 = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module processsymvec *)
procedure processsymvec(var symvec: text);
(* check for illegal blank lines in symvec *)
var
   done: boolean; (* done with the processing *)
begin
   done := false;
   while not done do begin
      if eof(symvec) then begin
         writeln(output,'symvec has a blank line at the end, this is not allowed');
         halt
      end
      else if symvec^='*'  then readln(symvec)
      else if symvec^=' '  then get(symvec)
      else if eoln(symvec) then readln(symvec)
      else done := true;
   end;
end;
(* end module processsymvec *)

(* begin module makelogo.postscriptstring *)
procedure postscriptstring(var instring, outstring, rawstring: string;
                           var symvec: text;
                           lowest, highest: integer;
                           rs, sd: real;
                           n: integer;
                           havers, havesd: boolean);
(* copy the instring to the outstring while protecting the
string by blocking postscript specific characters.  Example:
If the user typed    the result should be     so they get
      (                      \(                    (
     \)                       )                    \) (ie real postscript)
In the first case the user just said "I want a '('.  To do this,
we have to put protection on it.
In the second case the user said "I want a '(' as a postscript
command.  To do this, we have to remove the protection!  So this
procedure reverses the protection.  How curious.
The variable outlength reports the output length of the string
not counting real postscript commands so that the string
can be centered.  Of course since the user gives postscript
commands, they could do anything and that could mess up the
centering.  C'est la vie.
The rawstring is the string as the user would see it,
without control stuff or fancy postscript.

New commands:
   \i toggle italics on and off
   \n 5 produce number of sequences at coordinate 5
   \160 produce the Greek letter pi

New commands implemented 1999 Feb 20:
   \r produce Rsequence for the current range
   \s produce standard deviation for the current range

The symvec file is used to find the number of sequences
for the \n, \r and \d commands.  The lowest and highest values
are the range of the logo to use to compute Rs and sd.

 *)
const
   escape = '\'; (* the escape character is backslash *)
var
   curr: char; (* the current character on the line *)
   decimals: integer; (* number of decimal places for next real number *)
   i: integer; (* index to s *)
   italic: boolean; (* if true, do italics *)
   insidestring: boolean; (* are we inside a postscript string? *)
   needed: boolean; (* is protection needed? *)
   prev: char; (* the previous character on the line *)
   protectionchar: char; (* is protection needed? *)

procedure getchar;
(* step forward one character *)
begin
   i := succ(i);
   prev := curr;
   curr := instring.letters[i];
end; (* getchar *)

procedure putchar(c: char);
(* put the character c onto the end of outstring *)
begin
   outstring.length := succ(outstring.length);
   if outstring.length > maxstring then begin
      writeln(output,'postscriptstring: label too long, increase maxstring');
      halt
   end;
   outstring.letters[outstring.length] := c;

   (* Count characters that are inside unprotected postscript parens.
      That is, count the characters that will really be printed *)
   if insidestring then begin
       rawstring.length := succ(rawstring.length);
       rawstring.letters[rawstring.length] := c;
{
writeln(output,'length = ',length:2,
               ' char = "',letters[length],'"',
               insidestring);
}
   end
end; (* putchar *)
procedure badstring;
begin
   writeln(output,'This string:');
   writestring(output,instring);
   writeln(output);
   writeln(output,'is bad because parenthesis must be paired like this:');
   writeln(output,'"\)"  stuff "\("');
   writeln(output,'I am emptying the logo file.');
   rewrite(logo);
   halt
end; (* badstring *)

procedure doitalics;
(* generate:
38\) \( E. coli \) IT \(LexA binding sites
38) (E. coli ) IT (LexA binding sites
*)
begin
   insidestring := false;
   if italic then begin (* complete italics *)
      putchar(')');
      putchar(' ');
      putchar('I'); putchar('T');
      putchar(' ');
      putchar('(');
   end
   else begin (* start italics *)
      putchar(')');
      putchar(' ');
      putchar('(');
   end;
   insidestring := true;
   italic := not italic
end; (* doitalics *)

procedure dosymbol;
(* from:
38 \160 SY LexA binding sites
generate:
38) (160) SY (LexA binding sites
*)
begin
   insidestring := false;
   putchar(')');

   (* the symbol counts as a single space inside the string *)
   insidestring := true;
   putchar(' ');
   insidestring := false;

   putchar('(');
   putchar('\');
   putchar(curr);
   (*get two and put them *)
   getchar; putchar(curr);
   getchar; putchar(curr);
   putchar(')');
   putchar(' ');
   putchar('S'); putchar('Y');
   putchar(' ');
   putchar('(');
   insidestring := true;
end; (* dosymbol *)

procedure getnum(var num: integer);
(* pick up a number from the string *)
var
   done: boolean; (* done finding number *)
   numberstarted: boolean; (* have we started reading the number? *)
   sign: integer; (* -1 or +1 *)
   firsti: integer; (* start point for reading *)
begin
   sign := +1;
   done := false;
   numberstarted := false;
{
writeln(output,'This string:');
writestring(output,instring);
writeln(output);
}
   firsti := i;
   num := 0;
   while not done do begin
      i := succ(i);
      if i > instring.length then begin
         done := true (* number defaults to zero *)
      end
      else begin
         curr := instring.letters[i];
{
writeln(output,'curr="',curr,'"');
}
         if curr = '-' then begin
            if sign = -1 then begin
               writeln(output,'strings can have only one "-" in \n numbers');
               halt
            end;
            sign := -1;
            numberstarted := true
         end
         else if curr = '+' then begin
            if sign = -1 then begin
               writeln(output,'you cannot have both + and - signs in \n numbers');
               halt
            end;
         end
         else if curr in ['0','1','2','3','4','5','6','7','8','9'] then begin
            num := 10*num + (ord(curr) - ord('0'));
{
writeln(output,'    current num:',num:1);
}
            numberstarted := true
         end
         else if (curr <> ' ') or numberstarted then begin
            (* allow leading blanks *)
            done := true
         end;
      end;
   end;
   num := sign * num;
{
writeln(output,'num=',num:1);
}

   (* set string reading variable for further analysis *)
   i := pred(i);
   prev := ' ';
   curr := instring.letters[i];

   if not numberstarted then begin
      writeln(output,'WARNING: a number was not found in this string:');
      writestring(output,instring);
      writeln(output);
      writeln(output,'zero is being used');
      num := 0;
      i := firsti;
   end;

end;

procedure don;
(* insert the number of sequences into the string *)
var
   c: char; (* a character perhaps to be part of the output number *)
   coo: integer; (* current coordinate in symvec *)
   num: integer; (* current number in symvec *)
   maxcoo: integer; (* maximum coordinate in symvec *)
   maxnum: integer; (* maximum number in symvec *)
   sd: real; (* current sd in symvec *)
   rs: real; (* current rs in symvec *)
   desiredcoo: integer; (* the coordinate to get the number of sequences *)
   symbols: integer; (* number of symbols *)
   s: integer; (* index to symbols *)
begin

   getnum(desiredcoo);

   (* locate the coordinate in the symvec *)
   maxnum := -maxint;
   maxcoo := -maxint;

   (* skip header *)
   reset(symvec);
   if not eof(symvec) then begin
      processsymvec(symvec);
      readln(symvec, symbols);
   end;

   coo := -maxint;
   while (not eof(symvec)) and (coo <> desiredcoo) do begin
      processsymvec(symvec);
      readln(symvec,coo,num,rs,sd);
      if num >= maxnum then begin
         maxnum := num;
         maxcoo := coo;
      end;
      for s := 1 to symbols do readln(symvec);
   end;

   if eof(symvec) then begin
      (* we could be eof(symvec) for two reasons.  One is that
         we read to the end of the file.  The other is that
         the file is empty. *)
      reset(symvec);
      if eof(symvec)
      then begin (* symvec is empty *)
         coo := 0;
         num := 0;
         writeln(output,'* The symvec is empty.');
         writeln(output,'  Using ',coo:1,' for the coordinate and ',
                        num:1,' for the number.');
      end
      else begin (* we read to the end *)
         writeln(output,'* Coordinate ',desiredcoo:1, ' is not in the symvec:');
         writeln(output,'  the maximum value (',maxnum:1,
                        ') at coordinate ',maxcoo:1, ' will be used instead.');
         coo := maxcoo;
         num := maxnum;
      end
   end;

   (* now put the number into the output strings *)
   for s := numbersize(num) downto 0 do begin
      c := numberdigit(num,s);
      if (c <> ' ') and (c <> '+') then putchar(c);
   end;

   n := num;
   writeln(output,'* ',n:1,' sequences found at coordinate ',coo:1);
end; (* don *)

procedure getrssd;
(* get Rsequence and its sd *)
var
   b: integer; (* index to a symbol *)
   nl: integer; (* number of symbols at position l *)
   position: integer; (* a location in the aligned sequence (true coordinate) *)
   rsl: real; (* information at position l *)
   rsvar: real; (* variance of information at position l *)
   rstotal: real; (* sum of the rsl for the whole logo *)
   symbols: integer; (* number of symbols possible *)
   varhnb: real; (* variance of rstotal for the whole logo *)

begin
   reset(symvec);
   if eof(symvec)
   then begin (* symvec is empty *)
      writeln(output, 'symvec is empty: can''t do \r');
      halt
   end;

   processsymvec(symvec);
   readln(symvec, symbols);

   rstotal := 0.0;
   varhnb := 0.0;
   position := lowest;
   while (not eof(symvec) and (position <= highest)) do begin
      processsymvec(symvec);
      readln(symvec,position,nl,rsl,rsvar);

      if (position >= lowest) and (position <= highest) then begin
         rstotal := rstotal + rsl;
         varhnb := varhnb + rsvar;
      end;
 
      (* skip the symbols *)
      for b := 1 to symbols do begin
         processsymvec(symvec);
         readln(symvec); (* skip *)
      end;
   end;

   rs := rstotal;
   if varhnb >= 0
   then sd := sqrt(varhnb)
   else sd := 0.0;

   havers := true;
   havesd := true;

end;

procedure putreal(r: real; {wid,} dec: integer);
(* put a real number r into the string with dec decimal
places.  The total width of the number is not controlled;
there are no leading blanks.  If here are no decimal places,
the number is rounded.  If there are decimal places, the
number is rounded at the end.  (This is as one expects,
but the code is interesting.) *)
const
{
   debug = true; (* set true to debug *)
}
   debug = false; (* set true to debug *)
var
   c: char; (* part of the real number as a character *)
   m: integer; (* multiplier index *)
   num: integer; (* part of the real number *)
   s: integer; (* position in part of the number *)
begin
writeln(output,'******* putreal r = ,',r:5:3,' d = ',dec:1);
   if r < 0 then begin (* handle negative values *)
      c := '-';
      putchar(c);
      r := abs(r) (* set it positive for later work *)
   end;
   if dec > 0
   then begin
      (* 2007 Jan 10: BUG! *)
{
      (* move part below decimal above it: *)
      for m := 1 to dec do r := r * 10;
      (* round at that point only! *)
      r := round(r);
      (* put r back as it was, but rounded: *)
      for m := 1 to dec do r := r / 10;
      (* get part above decimal: *)
      num := trunc(r)
}
if debug then writeln(output, 'BB r initial   = ',r:10:5);

      (* move part below decimal above it: *)
      for m := 1 to dec do r := r * 10;
      (* round at that point only! *)
      r := round(r);
if debug then writeln(output, 'BB r rounded   = ',r:10:5);
      (* put r back as it was, but rounded: *)
      for m := 1 to dec do r := r / 10;
if debug then writeln(output, 'BB r divided   = ',r:10:5);
      (* get part above decimal: *)
      num := trunc(r);
if debug then writeln(output, 'BB r final     = ',r:10:5);
if debug then writeln(output, 'BB num = ',num:1);

   end
   else num := round(r);

   (* do part above decimal: *)
   for s := numbersize(num) downto 0 do begin
      c := numberdigit(num,s);
      if (c <> ' ') and (c <> '+') then putchar(c);
   end;

   (* do part below decimal: *)
   if dec > 0 then begin
      (* decimal point *)
      c := '.';
      putchar(c);
      (* digits after decimal point *)
      r := r - num; (* remove part above decimal point *)
if debug then writeln(output, 'BL r rm num    = ',r:10:5);

      (* move part below decimal above it: *)
      for m := 1 to dec do r := 10 * r;
if debug then writeln(output, 'BL r above     = ',r:10:5);
      num := round(r); (* round gives same result as Pascal *)
if debug then writeln(output, 'BL num         = ',num:10);
{
      (* 2007 Jan 10 bug here! - should be dec not numbersize! *)
      for s := numbersize(num) downto 0 do begin
}
if debug then writeln(output, 'BL numbersize(num) = ',numbersize(num):10);
if debug then writeln(output, 'BL dec             = ',dec            :10);
      for s := dec downto 0 do begin
         c := numberdigit(num,s);
{
2007 Jan 10: original code dropped spaces that should be zeros:
         if (c <> ' ') and (c <> '+') then putchar(c);
}
         if (c = ' ') and (dec = 1)
         then begin
           (* 2014 Dec 29
             Rs total is 12.99090 +/-  0.10369 bits
             was showing up as 13.00+/- 0.1.  The zero below if made to 'Z' gave
             13.Z0.  Solution: skip it, don't force an artificial zero! *)
         end
         else begin
            (* 2007 Jan 10 Bug solution:
               spaces are zeros below the decimal! *)
            if c =' ' then c := '0';
            if (c <> '+') then putchar(c);
         end
      end;
   end;
end;

procedure dors;
(* insert Rsequence into the string *)
begin
   if not havers then getrssd;
   putreal(rs, {infofield,} decimals);
   writeln(output,'* Rsequence for logo:',rs:infofield:decimals);
end;

procedure dosd;
(* insert standard deviation of Rsequence into the string *)
begin
   if not havesd then getrssd;
   putreal(sd, {infofield,} decimals);
   writeln(output,'* SD of Rsequence for logo:',sd:infofield:decimals);
end;

procedure dodecimal;
(* determine number of decimal places *)
begin
   getnum(decimals);
   writeln(output,'* decimal places set to: ',decimals:1);
end;

procedure badescapewarning(var f: text; fc: char);
(* produce a warning for bad escapes. fc is the first character
of the output line *)
begin
   writeln(f,fc,'************************************************');
   writeln(f,fc,'** UNKNOWN ESCAPE CHARACTER IN TITLE STRING  ***');
   writeln(f,fc,'** The character "',
                                 curr,'" is not allowed          ***');
   writeln(f,fc,'** following an escape backslash ("\")       ***');
   writeln(f,fc,'** in the title:                             ***');
   write(f,fc,'** "');
   writestring(f,instring);
   writeln(f,'"');
   if italic then begin
      writeln(f,fc,'** Italics string was not finished with "\i" ***');
   end;
   writeln(f,fc,'************************************************');
end;

begin (* postscriptstring *)
   if protecting then begin
      clearstring(outstring);
      clearstring(rawstring);
      curr := ' ';
      decimals := infodecim; (* default value *)
      italic := false;
      insidestring := false; (* we start outside the string *)
      putchar('(');
      insidestring := true; (* we are now inside the string *)

      i := 0;
      while i <= instring.length do begin;
         getchar;

         (* since we just got to a \) we are no longer inside the string *)
         if (prev = escape) and (curr = ')') then begin
            if not insidestring then badstring;
            insidestring := false;
         end;

         (* \\ gives \\ *)
         if (curr = escape) then begin
            if (prev = escape)
            then begin
               putchar(prev);
               putchar(curr);
            end;
         end
         else begin
            if prev <> escape 
            then begin
               protectcharacter(curr, protectionchar, needed);
               if needed then putchar(protectionchar);
            end;

            if (prev = escape) and (curr = 'i')
            then doitalics

            else if (prev = escape) and (curr = 'n')
            then don

            else if (prev = escape) and
                 (curr in ['0','1','2','3','4','5','6','7'])
            then dosymbol

            else if (prev = escape) and (curr = 'r') { \r }
            then dors

            else if (prev = escape) and (curr = 's') { \s }
            then dosd

            else if (prev = escape) and (curr = 'd') { \d }
            then dodecimal

            else if (prev = escape) then begin { \X where X is unknown! }
              badescapewarning(output, '*');
              badescapewarning(logo,   '%');
              halt;
            end
            else putchar(curr);  (* accept the current character *)

         end;

         (* now that we are past the \( we are truely inside the string *)
         if (prev = escape) and (curr = '(') then begin
            if insidestring then badstring;
            insidestring := true;
         end;
      end;
      if italic then begin
         writeln(output,'*** Italics string was not finished with "\i" ***');
         writeln(logo  ,'%** Italics string was not finished with "\i" ***');
         halt
      end;

      if insidestring
      then insidestring := false
      else begin
         writeln(output,'This string:');
         writestring(output,instring);
         writeln(output);
         writeln(output,'is bad because it needs a final "\(".');
         writeln(output,'I am emptying the logo file.');
         rewrite(logo);
         halt
      end;

      (* close italics if necessary *)
      if italic then doitalics;

      putchar(')');
   end
   else begin
      copystring(instring, outstring);
      copystring(instring, rawstring);
   end

{
;
write(output,' instring = "');
writestring(output,instring);
writeln(output,'"');

write(output,'outstring = "');
writestring(output,outstring);
writeln(output,'"');

write(output,'rawstring = "');
writestring(output,rawstring);
writeln(output,'"');
}

end; (* postscriptstring *)
(* end module makelogo.postscriptstring *)

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

(* begin module makelogo.truth *)
procedure truth(var f: text; b: boolean);
(* write the true-false value of b to file f *)
begin
  if b then write(f,'true')
       else write(f,'false');
end;
(* end module makelogo.truth *)

(* begin module makelogo.p1 *)
procedure p1(var l: text; params: parameters);
begin with params do begin
writeln(l,'%');
writeln(l,'% logo from ',lowest:1,' to ',highest:1);
writeln(l);

{zzzbbb}
if formcontrol = 'e' then barbits := 1; (* force frequency scale! *)
if formcontrol = 'e' then subticsBig := 10; (* force frequency scale! *)

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

writeln(l,'% user defined parameters');
writeln(l,'/lowest ',lowest:1,' def');
writeln(l,'/highest ',highest:1,' def');
writeln(l,'/bar ',bar:1,' def');
writeln(l,'/xcorner ',xcorner:pwid:pdec,' cm def');
writeln(l,'/ycorner ',ycorner:pwid:pdec,' cm def');
writeln(l,'/rotation ',rotation:pwid:pdec,' def % degrees');
writeln(l,'/charwidth ',charwidth:pwid:pdec,' cm def');
writeln(l,'/charwidth2m charwidth 2 mul def');
writeln(l,'/barheight ',barheight:pwid:pdec,' cm def');
writeln(l,'/barwidth ',barwidth:pwid:pdec,' cm def');
writeln(l,'/barbits ',barbits:pwid:pdec,' def % bits');
writeln(l,'/Ibeamfraction ',Ibeamfraction:pwid:pdec, ' def');
writeln(l,'/barends (',barends,') def');
writeln(l,'/subticsBig ',subticsBig:1,' def % sub-tic interval size (1/bits)');
writeln(l,'/subticsSmall ',subticsSmall:1,' def % sub-tic interval size (1/bits)');
writeln(l,'/showingbox (', showingbox,') def');
write  (l,'/outline '); truth(l,outline); writeln(l,' def');
write  (l,'/caps '); truth(l,caps); writeln(l,' def');
writeln(l,'/stacksperline ',stacksperline:1,' def');
writeln(l,'/linesperpage ',linesperpage:1,' def');
writeln(l,'/linemove ',linemove:pwid:pdec,' def');
write  (l,'/numbering '); truth(l,numbering); writeln(l,' def');
write  (l,'/shrinking '); truth(l,shrinking); writeln(l,' def');
writeln(l,'/edgecontrol (',edgecontrol,') def');
writeln(l,'/edgeleft ',edgeleft:pwid:pdec,' def');
writeln(l,'/edgeright ',edgeright:pwid:pdec,' def');
writeln(l,'/edgelow ',edgelow:pwid:pdec,' def');
writeln(l,'/edgehigh ',edgehigh:pwid:pdec,' def');
writeln(l,'/shrink ',shrink:pwid:pdec,' def');
writeln(l,'/ShowEnds (',ShowEnds,') def % d: DNA, p: PROTEIN, -: none');
write  (l,'/HalfWhiteIbeam '); truth(l,HalfWhiteIbeam); writeln(l,' def');
writeln(l,'/squashspray ',squashspray:pwid:pdec,' def');

writeln(l);
writeln(l,'/knirhs 1 shrink sub 2 div def');
writeln(l,'/charwidth4 charwidth 4 div def');
writeln(l,'/charwidth2 charwidth 2 div def');
writeln(l);

(*
writeln(l,'/outlinethinness ',outlinethinness:1,' def');
writeln(l,'outline');
writeln(l,'  {/setthelinewidth {charwidth outlinethinness div setlinewidth} def}');
writeln(l,'  {/setthelinewidth {1 setlinewidth} def}');
writeln(l,'ifelse');
writeln(l,'setthelinewidth % set to normal linewidth');
*)

writeln(l,'/outlinewidth {charwidth ',outlinethinness:1,' div} def');
writeln(l,'/setthelinewidth {% set the linewidth');
writeln(l,'  outline');
writeln(l,'    {outlinewidth setlinewidth}');
writeln(l,'    {1 setlinewidth}');
writeln(l,'  ifelse');
writeln(l,'} def');

writeln(l,'/toggleoutline { % switch the state of outlineing');
writeln(l,'pop pop pop pop');
writeln(l,'/outline outline not def');
writeln(l,'setthelinewidth');
writeln(l,'} def');


writeln(l);
writeln(l,'% define fonts');
writeln(l,'/ffss {findfont fontsize scalefont setfont} def');
(* 2015 Jul 30 switch to Helvetica for strings; better for figures!
writeln(l,'/FontForStringRegular {/Times-Bold       ffss} def');
*)
writeln(l,'/FontForStringRegular {/Helvetica-Bold       ffss} def');
(* 2023 Dec 02 switch to Helvetica for strings; better for figures!
writeln(l,'/FontForStringItalic  {/Times-BoldItalic ffss} def');
*)
writeln(l,'/FontForStringItalic  {/Helvetica-BoldItalic ffss} def');
writeln(l,'/FontForLogo          {/Helvetica-Bold   ffss} def');
writeln(l,'/FontForPrime         {/Symbol           ffss} def');
writeln(l,'/FontForSymbol        {/Symbol           ffss} def');

writeln(l);
writeln(l,'% Set up the font size for the graphics');
writeln(l,'/fontsize charwidth def');

writeln(l);
writeln(l,'% movements to place 5'' and 3'' symbols');
writeln(l,'/fivemovex {0} def');
writeln(l,'/fivemovey {(0) charparams lx ux sub 3 mul} def');
writeln(l,'/threemovex {(0) stringwidth pop 0.5 mul} def');
writeln(l,'/threemovey {fivemovey} def');
(* \242 is a prime symbol according to the Symbol Encoding Vectors *)
writeln(l,'/prime {FontForPrime (\242) show FontForStringRegular} def');

writeln(l);
writeln(l,'% make italics possible in titles');
writeln(l,'/IT {% TRstring ITstring IT -');
writeln(l,'  exch show');
writeln(l,'  FontForStringItalic');
writeln(l,'  show');
writeln(l,'  FontForStringRegular');
writeln(l,'} def');
writeln(l);

writeln(l);
writeln(l,'% make symbols possible in titles');
writeln(l,'/SY {% TRstring SYstring SY -');
writeln(l,'  exch show');
writeln(l,'  FontForSymbol');
writeln(l,'  show');
writeln(l,'  FontForStringRegular');
writeln(l,'} def');
writeln(l);

end; end;
(* end module makelogo.p1 *)

(* begin module makelogo.p2 *)
procedure p2(var l, colors: text; params: parameters);
var
  symbol: char; (* a symbol to which to assign a color *)
  red, green, blue: real; (* color definitions *)
begin with params do begin
write(l,'%');
writeln(l,'(','*[','[ This special comment allows deletion of the repeated');
writeln(l,'% procedures when several logos are concatenated together');
writeln(l,'% See the censor program.');
writeln(l);

writeln(l,'/charparams { % char charparams => uy ux ly lx');
writeln(l,'% takes a single character and returns the coordinates that');
writeln(l,'% defines the outer bounds of where the ink goes');
writeln(l,'  gsave');
writeln(l,'    newpath');
writeln(l,'    0 0 moveto');
writeln(l,'    % take the character off the stack and use it here:');
writeln(l,'    true charpath ');
writeln(l,'    flattenpath ');
writeln(l,'    pathbbox % compute bounding box of 1 pt. char => lx ly ux uy');
writeln(l,'    % the path is here, but toss it away ...');
writeln(l,'  grestore');
writeln(l,'  /uy exch def');
writeln(l,'  /ux exch def');
writeln(l,'  /ly exch def');
writeln(l,'  /lx exch def');
(*
writeln(l,'%     % print the parameters to the user:');
writeln(l,'%     (lx) lx (ly) ly (ux) ux (uy) uy pstack');
writeln(l,'%     clear % clean up the stack, having printed all that');
*)
writeln(l,'} bind def');
writeln(l);

writeln(l,'/dashbox { % xsize ysize dashbox -');
writeln(l,'% draw a dashed box of xsize by ysize (in points)');
writeln(l,'  /ysize exch def % the y size of the box');
writeln(l,'  /xsize exch def % the x size of the box');
writeln(l,'  1 setlinewidth');
writeln(l,'  gsave');
writeln(l,'    % Define the width of the dashed lines for boxes:');
writeln(l,'    newpath');
writeln(l,'    0 0 moveto');
writeln(l,'    xsize 0 lineto');
writeln(l,'    xsize ysize lineto');
writeln(l,'    0 ysize lineto');
writeln(l,'    0 0 lineto');
writeln(l,'    [3] 0 setdash');
writeln(l,'    stroke');
writeln(l,'  grestore');
writeln(l,'  setthelinewidth');
writeln(l,'} bind def');
writeln(l);

writeln(l,'/boxshow { % xsize ysize char boxshow');
writeln(l,'% show the character with a box around it, sizes in points');
writeln(l,'gsave');
writeln(l,'  /tc exch def % define the character');
writeln(l,'  /ysize exch def % the y size of the character');
writeln(l,'  /xsize exch def % the x size of the character');
writeln(l,'  /xmulfactor 1 def /ymulfactor 1 def');
writeln(l);

writeln(l,'  % if ysize is negative, make everything upside down!');
writeln(l,'  ysize 0 lt {');
writeln(l,'    % put ysize normal in this orientation');
writeln(l,'    /ysize ysize abs def');
writeln(l,'    xsize ysize translate');
writeln(l,'    180 rotate');
writeln(l,'  } if');
writeln(l);

writeln(l,'  shrinking {');
writeln(l,'    xsize knirhs mul ysize knirhs mul translate');
writeln(l,'    shrink shrink scale');
writeln(l,'  } if');
writeln(l);

writeln(l,'  2 {');
writeln(l,'    gsave');
writeln(l,'    xmulfactor ymulfactor scale');
writeln(l,'    tc charparams');
writeln(l,'    grestore');
writeln(l);

(* NOTE:  The following if statements in the next two sections make sure that
the size of the character has not gone to zero.  This apparently can happen
under OpenWindows, but not NeWS the Apple laserwriter or Freedom of the Press
Tektronix colorquick conversion. *)

writeln(l,'    ysize % desired size of character in points');
writeln(l,'    uy ly sub % height of character in points');
writeln(l,'    dup 0.0 ne {');
writeln(l,'      div % factor by which to scale up the character');
writeln(l,'      /ymulfactor exch def');
writeln(l,'    } % end if');
writeln(l,'    {pop pop}');  (* remove the stuff from the stack and go on *)
writeln(l,'    ifelse');
writeln(l);
writeln(l,'    xsize % desired size of character in points');
writeln(l,'    ux lx sub % width of character in points');
writeln(l,'    dup 0.0 ne {');
writeln(l,'      div % factor by which to scale up the character');
writeln(l,'      /xmulfactor exch def');
writeln(l,'    } % end if');
writeln(l,'    {pop pop}');
writeln(l,'    ifelse');
writeln(l,'  } repeat');
writeln(l);

(* The letter I must be specially centered in the Helvetica-Bold font.
We also account for the width of the character itself, so it should be centered
perfectly. *)
writeln(l,'  % Adjust horizontal position if the symbol is an I');
writeln(l,'  tc (I) eq {charwidth 2 div % half of requested character width');
writeln(l,'             ux lx sub 2 div % half of the actual character');
writeln(l,'                sub      0 translate} if');
writeln(l,'  % Avoid x scaling for I');
writeln(l,'  tc (I) eq {/xmulfactor 1 def} if');
writeln(l);

writeln(l,'  /xmove xmulfactor lx mul neg def');
writeln(l,'  /ymove ymulfactor ly mul neg def');
writeln(l);

writeln(l,'  newpath');
writeln(l,'  xmove ymove moveto');
writeln(l,'  xmulfactor ymulfactor scale');
writeln(l);

writeln(l,'  outline {  % outline characters:');
(* get the character's path: *)
writeln(l,'setthelinewidth');
writeln(l,'    tc true charpath');
(* erase the center of the character (seems necessary to do!) *)
writeln(l,'    gsave 1 setgray fill grestore');
(* clip everything outside the character to prevent characters
from overlapping each other (!) and then stroke the edge.
Thus only the part of the stroke that reaches into the CENTER
of the character becomes black and so the character size does
not change even though it is an outline. *)
writeln(l,'    clip stroke');
writeln(l,'}');

writeln(l,'  { % regular characters');
writeln(l,'    tc show');
writeln(l,'  }');
writeln(l,'  ifelse');

writeln(l,'grestore');
writeln(l,'} def');
writeln(l);

writeln(l,'/numchar{ % charheight character numchar');
writeln(l,'% Make a character of given height in cm,');
writeln(l,'% then move vertically by that amount');
writeln(l,'  gsave');
writeln(l,'    /char exch def');
writeln(l,'    /charheight exch cm def');

(* Set up the color statements. *)
reset(colors);
writeln(l,'    /visible true def % most characters are visible');
while not eof(colors) do begin
   if (colors^ <> '*')       (* skip comment lines *)
      and (not eoln(colors)) (* ignore blank lines too 2007 Mar 31 *)
   then begin
      (* implement the backslash protection scheme: *)
      if colors^ = '\' then get(colors);
      readln(colors,symbol,red,green,blue);

      if ((symbols = 4)
          and (capitalize(symbol) <> symbol))
              (* ie ignore capitalized symbols for DNA logo *)
         or
         (symbols <> 4)
      then begin

         if symbols = 4 then begin
            (* 2007 Mar 31: handle the situation when
               the user wants capitals for the logo but supplies
               (as standard) lower case for the color definition *)
            if caps then begin
               if capitalize(symbol) <> symbol then begin
                  symbol := capitalize(symbol);
               end;
            end;
         end;

         write(l,'    char (');
         protectpostscript(l,symbol);
         write(l,symbol,') eq {');
         if (red < 0) or (green < 0) or (blue < 0)
         then begin
            writeln(output,'Character ',symbol,' will be invisible');
            writeln(l,'0 0 0 setrgbcolor /visible false def } if');
         end
         else begin
            if (red = 1.0) or (red = 0.0) then write(l,round(red):1)
                                          else write(l,red:pwid:pdecolor);
            write(l,' ');
            if (green = 1.0) or (green = 0.0) then write(l,round(green):1)
                                              else write(l,green:pwid:pdecolor);
            write(l,' ');
            if (blue = 1.0) or (blue = 0.0) then write(l,round(blue):1)
                                            else write(l,blue:pwid:pdecolor);
            writeln(l,' setrgbcolor} if');
         end
      end
   end
   else readln(colors);
end;


writeln(l,'     % (* 2018 Jul 25 squash-spray test *)');
(*
writeln(l,'     charheight ',squashspray:4:2,' le {'); 
*)
writeln(l,'     charheight squashspray le {');
writeln(l,'        /visible false def % low height characters dropped');
writeln(l,'        % Show the character as a rectangle if it would');
writeln(l,'        % break the postscript display program.');
writeln(l,'        ly lx');
writeln(l,'        ly charwidth add');
writeln(l,'        lx charheight add');
writeln(l,'        boxsymbol');
writeln(l,'        clip');
writeln(l,'        fill');
writeln(l,'     } if');

writeln(l,'     visible {');
writeln(l,'       % implement boxes, fill and characters:');
writeln(l,'       showingbox (s) eq');
writeln(l,'       showingbox (f) eq');
writeln(l,'       or');
writeln(l,'       {gsave');
                      (* Prepare the character path *)
writeln(l,'           ly lx');
writeln(l,'           ly charwidth add');
writeln(l,'           lx charheight add');
writeln(l,'           boxsymbol');
writeln(l,'           clip');
                      (* Show a rectangle by fill or as a character: *)
writeln(l,'           showingbox (f) eq');
writeln(l,'           {fill}  ');
writeln(l,'           {gsave 0 setgray stroke grestore  ');
writeln(l,'            charwidth charheight char boxshow');
writeln(l,'           }');
writeln(l,'           ifelse');
writeln(l,'       grestore');
writeln(l,'       }');
writeln(l,'       {charwidth charheight char boxshow}');
writeln(l,'       ifelse');
writeln(l,'     } if % visibility control');

writeln(l,'  grestore');

(* note: adding the following text is sufficient to cause
the converter to C to bomb with a segmentation fault!
writeln(l,'    % note: charwidth and charheight');
writeln(l,'    %  have already been converted to points');
*)

(*
writeln(l,'  % the abs in the translation function below',
          ' handles negative heights');
*)

(* The following if statements ask if the character height is greater than
one point.  If it is, the display should be ok.  If not, some
displays mess up, notably OpenWindows (!).  Force the character
to be 1 point high just to be safe.  I hate bad implementations
of PostScript! *)

if gooddisplay
then writeln(l,'  0 charheight abs translate')
else writeln(l,'  charheight abs 1 gt {0 charheight abs translate} if');

writeln(l,'} bind def'); (* numchar *)
writeln(l);

end; end;
(* end module makelogo.p2 *)

(* begin module makelogo.p3 *)
procedure p3(var l: text; params: parameters);
begin with params do begin

writeln(l,'/Ibar{');
writeln(l,'% make a horizontal bar');
writeln(l,'gsave');
writeln(l,'  newpath');
writeln(l,'    charwidth4 neg 0 moveto');
writeln(l,'    charwidth4 0 lineto');
writeln(l,'  stroke');
writeln(l,'grestore');
writeln(l,'} bind def'); (* Ibar *)
writeln(l);

writeln(l,'/Ibeam{ % height Ibeam');
writeln(l,'% Make an Ibeam of twice the given height, in cm');
writeln(l,'  /height exch cm def');
writeln(l,'  /heightDRAW height Ibeamfraction mul def');
writeln(l,'  1 setlinewidth');
writeln(l,'     HalfWhiteIbeam outline not and');
writeln(l,'     {0.75 setgray} % grey on bottom');
writeln(l,'     {0 setgray} % black on bottom');
writeln(l,'  ifelse');
writeln(l,'  gsave');
writeln(l,'    charwidth2 height neg translate');
writeln(l,'    Ibar');
writeln(l,'    newpath');
writeln(l,'      0 0 moveto');
writeln(l,'      0 heightDRAW rlineto');
writeln(l,'    stroke');
writeln(l,'    0 setgray % black on top');
writeln(l,'    newpath');
writeln(l,'      0 height moveto');
writeln(l,'      0 height rmoveto');
writeln(l,'      currentpoint translate');
writeln(l,'    Ibar');
writeln(l,'    newpath');
writeln(l,'      0 0 moveto');
writeln(l,'      0 heightDRAW neg rlineto');
writeln(l,'      currentpoint translate');
writeln(l,'    stroke');
writeln(l,'  grestore');
writeln(l,'  setthelinewidth');
writeln(l,'} bind def'); (* Ibeam *)
writeln(l);

(* The original simple Ibeam
writeln(l,'/Ibeam{ % height Ibeam');
writeln(l,'% Make an Ibeam of twice the given height, in cm');
writeln(l,'  /height exch cm def');
writeln(l,'  1 setlinewidth');
writeln(l,'  0 setgray % black');
writeln(l,'  gsave');
writeln(l,'    charwidth2 height neg translate');
writeln(l,'    Ibar');
writeln(l,'    newpath');
writeln(l,'      0 0 moveto');
writeln(l,'      0 height 2 mul lineto');
writeln(l,'      currentpoint translate');
writeln(l,'    stroke');
writeln(l,'    Ibar');
writeln(l,'  grestore');
writeln(l,'  setthelinewidth');
writeln(l,'} bind def'); (# Ibeam #)
writeln(l);
*)

writeln(l,'/makenumber { % number makenumber');
writeln(l,'% make the number');
writeln(l,'gsave');
writeln(l,'  shift % shift to the other side of the stack');
writeln(l,'  90 rotate % rotate so the number fits');
writeln(l,'  dup stringwidth pop % find the length of the number');
writeln(l,'  neg % prepare for move');
writeln(l,'  charwidth (0) charparams uy ly sub % height of numbers');
writeln(l,'  sub 2 div %');
writeln(l,'  moveto % move back to provide space');
writeln(l,'  show');
writeln(l,'grestore');
writeln(l,'} bind def'); (* makenumber *)
writeln(l);

writeln(l,'/shift{ % move to the next horizontal position');
writeln(l,'charwidth 0 translate');
writeln(l,'} bind def');
writeln(l);

(* 1996 March 16
The vertical bar should NOT affect the coordinate system!
"make a vertical bar and shift" is no longer acceptable.
The bar is made, but centered on the current location.
No movement is made.  The reason for this is that it messes
up the precise centering of strings and it would mess up the
location of marks. *)

writeln(l,'/bar2 barwidth 2 div def');
writeln(l,'/bar2n bar2 neg def');
writeln(l,'/makebar { % make a vertical bar at the current location');
writeln(l,'gsave');
writeln(l,'   bar2n 0 moveto');
writeln(l,'   barwidth 0 rlineto');
writeln(l,'   0 barheight rlineto');
writeln(l,'   barwidth neg 0 rlineto');
writeln(l,'   closepath');
writeln(l,'   fill');
writeln(l,'grestore');
writeln(l,'} def');
writeln(l);

writeln(l,'% definitions for maketic');
writeln(l,'/str 10 string def % string to hold number');
writeln(l,'% points of movement between tic marks:');
writeln(l,'% (abs protects against barbits being negative)');
writeln(l,'/ticmovement barheight barbits abs div def');
writeln(l);
writeln(l,'/maketic { % make tic marks and numbers');
writeln(l,'% define tic mark to be the width of the number 4:');
writeln(l,'(4) stringwidth pop');
writeln(l,'/ticwidth exch def % width of tic (as a dash) to show');
writeln(l,'gsave');
writeln(l,'  % initial increment limit proc for');
writeln(l,'  0 1 barbits abs cvi');
writeln(l,'  {/loopnumber exch def');
writeln(l);
writeln(l,'    % convert the number coming from the loop to a string');
writeln(l,'    % and find its width');
writeln(l,'    loopnumber 10 str cvrs');
writeln(l,'    /stringnumber exch def % string representing the number');
writeln(l);
writeln(l,'    stringnumber stringwidth pop');
writeln(l,'    /numberwidth exch def % width of number to show');
writeln(l);
writeln(l,'    /halfnumberheight');
writeln(l,'      stringnumber charparams % capture sizes');
writeln(l,'      uy ly sub 2 div');
writeln(l,'    def');
writeln(l);
{ it was inefficient to define the tic inside the loop:
writeln(l,'    % define tic mark');
writeln(l,'    (4) stringwidth pop');
writeln(l,'    /ticwidth exch def % width of tic (as a dash) to show');
}
writeln(l);
writeln(l,'    numberwidth % move back width of number');
writeln(l,'    neg loopnumber ticmovement mul % shift on y axis');
writeln(l,'    halfnumberheight sub % down half the digit');
writeln(l);
writeln(l,'    moveto % move back the width of the string');
writeln(l);
writeln(l,'    ticwidth neg 0 rmoveto % move back the width of the tic');
writeln(l);
writeln(l,'    stringnumber show');
writeln(l);
writeln(l,'    % now show the tic mark');
writeln(l,'    0 halfnumberheight rmoveto % shift up again');
writeln(l,'    ticwidth 0 rlineto');
writeln(l,'    stroke');
(* note: the following two lines are separated to avoid a
problem with the p2c Pascal to C translator *)
write  (l,'  }'); writeln(l,' for');
writeln(l,'grestore');
writeln(l);

writeln(l,'% do additional BIG tic marks.  subtics is user defined');
writeln(l,'  % initial increment limit proc for');
writeln(l,'gsave');
{for testing, to see the new tic marks:
writeln(l,'1 0 0 setrgbcolor % set color to red');
}
writeln(l,'  0 1 barbits subticsBig mul abs cvi');
writeln(l,'  {/bitnumber exch subticsBig div subticsBig div def');
writeln(l,'    0');
writeln(l,'    neg bitnumber ticmovement mul subticsBig mul % shift on y axis');
writeln(l,'    moveto');
writeln(l,'    ticwidth neg 0 rlineto');
writeln(l,'    stroke');
write  (l,'  }'); writeln(l,' for');

writeln(l,'/subticsBig ',subticsBig:1,' def % sub-tic interval size (1/bits)');

writeln(l,'% do additional SMALL tic marks.  subticsSmall is user defined');
writeln(l,'/ticwidth ticwidth 2 div def % halve the ticwidth');
writeln(l,'  % initial increment limit proc for');
writeln(l,'gsave');
{for testing, to see the new tic marks:
writeln(l,'1 0 0 setrgbcolor % set color to red');
}
writeln(l,'  0 1 barbits subticsSmall mul abs cvi');
writeln(l,'  {/bitnumber exch subticsSmall div subticsSmall div def');
writeln(l,'    0');
writeln(l,'    neg bitnumber ticmovement mul subticsSmall mul',
          ' % shift on y axis');
writeln(l,'    moveto');
writeln(l,'    ticwidth neg 0 rlineto');
writeln(l,'    stroke');
write  (l,'  }'); writeln(l,' for');

writeln(l,'grestore');

(*
writeln(l,'% at this point numberwidth says how far back to go.  do that');
*)
           (* put the word 'bits' or 'frequency' on the left *)
writeln(l,'gsave');

{zzzbbb}
if formcontrol = 'e'
then writeln(l,'  /labelstring (frequency) def')
else writeln(l,'  /labelstring (bits) def');

writeln(l,'  numberwidth neg 2.5 mul');  (* x coordinate to start writing *)
writeln(l,'  barheight'); (* height of bar *)
writeln(l,'  labelstring stringwidth pop'); (* length of string *)
writeln(l,'  sub 2 div');  (* y coordinate to start writing *)
writeln(l,'  translate');
writeln(l,'  90 rotate');
writeln(l,'  0 0 moveto');
writeln(l,'  labelstring show');  (* x coordinate to start writing *)
writeln(l,'grestore');

writeln(l,'} def');

end; end;
(* end module makelogo.p3 *)

(* begin module startcosine *)
procedure startcosine(var l: text);
(* write the postscript definitions to make a cosine wave *)
(* example test:
% amplitude  phase  wavelength  base:
 -2.50000 cm  6.40000 cm  8.48000 cm  7.50000 cm
% xmin ymin xmax ymax step:
 -4.80000 cm  0.00000 cm 17.60000 cm 50.50000 cm 1
  0.5 cm 0.1 drawcosine
*)
begin
writeln(l);
writeln(l,'/degpercycle 360 def');
writeln(l,' ');
writeln(l,'/drawcosine {% amplitude  phase  wavelength  base');
writeln(l,'%              xmin ymin xmax ymax step');
writeln(l,'%              dashon dashoff dashoffset thickness');
writeln(l,'%              cosine -');
writeln(l,'% draws a cosine wave with the given parameters:');
writeln(l,'% amplitude (points): height of the wave');
writeln(l,'% phase (points): starting point of the wave');
writeln(l,'% wavelength (points): length from crest to crest');
writeln(l,'% base (points): lowest point of the curve');
writeln(l,'% xmin ymin xmax ymax (points): region in which to draw');
writeln(l,'% step steps for drawing a cosine wave');
writeln(l,'% dashon if greater than zero, size of dashes of the wave (points)');
writeln(l,'% dashon dashing on interval (points)');
writeln(l,'% dashoff dashing off interval (points)');
writeln(l,'% dashoffset offset for dashing (points)');
writeln(l,'% thickness if greater than zero, thickness of wave (points)');
writeln(l,'% use dashon and dashoff as blank and dashoffset as 0 for solid line');
writeln(l,'% See PostScrirt Language Reference Manual 2nd ed p. 500 on dash.');
writeln(l);
writeln(l,'  /thickness exch def');
writeln(l,'  /dashoffset exch def');
writeln(l,'  /dashoff exch def');
writeln(l,'  /dashon exch def');
writeln(l,'  /step exch def');
writeln(l,'  /ymax exch def');
writeln(l,'  /xmax exch def');
writeln(l,'  /ymin exch def');
writeln(l,'  /xmin exch def');
writeln(l,'  /base exch def');
writeln(l,'  /wavelength exch def');
writeln(l,'  /phase exch def');
writeln(l,'  /amplitude exch def');
writeln(l,'  % fun := amplitude*cos( ((-y-phase)/wavelength)*360) + base');
writeln(l,'  /fun {phase sub wavelength div degpercycle mul cos');
writeln(l,'           amplitude mul base add} def');
writeln(l);
writeln(l,'  gsave');
writeln(l,'    /originallinewidth currentlinewidth def');
writeln(l,'    thickness 0 gt {thickness setlinewidth} if');
writeln(l);
writeln(l,'    % Force the curve to fit into the region specified:');
writeln(l,'    newpath');
writeln(l,'    xmin ymin moveto');
writeln(l,'    xmax ymin lineto');
writeln(l,'    xmax ymax lineto');
writeln(l,'    xmin ymax lineto');
writeln(l,'    closepath');
writeln(l,'    clip'); (* stroke'); *)
writeln(l);
writeln(l,'    newpath');
writeln(l,'    xmin dup fun moveto');
writeln(l,'    % go to xmin-1 and xmax+1 to make sure we overlap the');
writeln(l,'    % next wave if there is one.  The clip above ensures that it');
writeln(l,'    % goes no further than requested. ');
writeln(l,'    % loop from xmin-1 to xmax+1 by step:');
writeln(l,'    xmin 1 sub step xmax 1 add {dup fun lineto} for');
writeln(l,'    % turn dash on if dashon is positive');
writeln(l,'    dashon 0 gt {[dashon cvi dashoff cvi] dashoffset setdash} if');
writeln(l,'    stroke');
writeln(l);
writeln(l,'    originallinewidth setlinewidth');
writeln(l,'  grestore');
writeln(l,'} bind def');
writeln(l);
end;
(* end module startcosine version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.p4 *)
procedure p4(var l: text);
begin
  startcosine(l);
end;
(* end module makelogo.p4 *)

(* begin module makelogo.p4a *)
procedure p4a(var l: text; params: parameters);
begin with params do begin

writeln(l,'% The following special comment allows deletion of the repeated');
writeln(l,'% procedures when several logos are concatenated together');
writeln(l,'% See the censor program.');
writeln(l,'%',']',']','%','*',')');

writeln(l);
writeln(l,'/startpage { % start a page');
writeln(l,'  save % [ startpage'); (* required for packaging page *)
writeln(l,'  % set the font used in the title strings');
writeln(l,'  FontForStringRegular');
writeln(l,'  gsave % [ startpage');
writeln(l,'  xcorner ycorner translate');
writeln(l,'  rotation rotate');
end; end;
(* end module makelogo.p4a *)

(* begin module makelogo.p5 *)
procedure p5(var l, symvec: text; params: parameters);
var
  stringspot: stringsptr; (* current spot in thestrings *)
  stringnumber: integer; (* count of the strings written *)
  printstring: string; (* the string to print after processing. *)
  rawstring: string; (* the raw string that will print, ignoring
     any fancy postscript the user may have introduced. *)
  rs: real; (* value of rs *)
  sd: real; (* value of sd *)
  n: integer; (* number of sequences *)
  havers, havesd: boolean; (* have gotten rs, sd *)
begin with params do begin

if thestrings <> nil then begin
   writeln(l,'  % create the user defined strings');
   stringspot := thestrings;
   stringnumber := 0;

   rs := 0.0;
   sd := 0.0;
   n := 0;
   havers := false;
   havesd := false;
   
   while stringspot <> nil do begin
      writeln(l,'  gsave');
      postscriptstring(stringspot^.astring,printstring,rawstring,
                       symvec,lowest, highest,
                       rs, sd, n, havers, havesd);
      if stringspot^.x <= centertrigger then begin (* test for centering *)

         (* check if the user will be fooled by the loss of the string *)
         if stacksperline > 2*(highest - lowest) then begin
            writeln(output);
            writeln(output,'WARNING: if you don''t see centered string number ',
                           stringnumber:1,':');
            write(output,'    "');
            writestring(output,stringspot^.astring);
            writeln(output,'"');
            writeln(output,'it may be off the page because stacksperline',
                           ' is large (',stacksperline:1,') relative to the');
            writeln(output,'FROM-TO range (',
                            lowest:1,' to ',highest:1,')',
                           ' and centering is based on stacks-per-line.',
                           '  To');
            writeln(output,'solve this, reduce parameter stacksperline to',
                           ' FROM-TO+1 = ',(highest-lowest+1):1);
            writeln(output);
         end;

         stringnumber := stringnumber + 1;
         writeln(l,'    % string number ',stringnumber:1);
         writeln(l,'    % center the string');
         writeln(l,'    /stringscale ',stringspot^.s:pwid:pdec, ' def');

{ code for looking at the centering
writeln(l,'gsave % draw a vertical line at the center of the graph');
writeln(l,'     stacksperline charwidth mul');
writeln(l,'     2 div');
writeln(l,'     10.20000 cm moveto');
writeln(l,'  ');
writeln(l,' % Its the bar width!!!');
writeln(l,'  ');
writeln(l,'   0 -10.1 cm rlineto');
writeln(l,'   stroke ');
write(l,'% draw a horizontal line under the string');
write(l,'    (');
writestring(l,rawstring);
writeln(l,')');
writeln(l,'    stringwidth pop /thestringwidth exch def');
writeln(l,'    thestringwidth');
writeln(l,'    stringscale mul neg');
writeln(l,'    stacksperline charwidth mul');
writeln(l,'    add 2 div');
writeln(l,'    ',stringspot^.y:pwid:pdec,' cm moveto');
writeln(l,'   thestringwidth 0 rlineto');
writeln(l,'   stroke ');
writeln(l,' grestore');
writeln(l);
}

{
write(output,' printstring: "');
writestring(output,printstring);
writeln(output,'"');
}

         write(l,'    (');
         writestring(l,rawstring);
         writeln(l,')');
         writeln(l,'    stringwidth pop');
         writeln(l,'    stringscale mul neg');
         writeln(l,'    stacksperline charwidth mul');
         writeln(l,'    add 2 div');
         writeln(l,'    ',stringspot^.y:pwid:pdec,' cm moveto');

      end
      else begin
         writeln(l,'    /stringscale ',stringspot^.s:pwid:pdec, ' def');
         writeln(l,'    ',stringspot^.x:pwid:pdec,' cm',
                        ' ',stringspot^.y:pwid:pdec,' cm moveto');
      end;
      writeln(l,'    stringscale stringscale scale');
      write  (l,'    ');
      writestring(l,printstring);
      writeln(l);
      writeln(l,'    show');
      stringspot := stringspot^.next;
      writeln(l,'  grestore')
   end;
end;

end; end;
(* end module makelogo.p5 *)

(* begin module makelogo.p6 *)
procedure p6(var l: text; params: parameters);
begin with params do begin

writeln(l,'  % now move up to the top of the top line:');
writeln(l,'  0 linesperpage linemove barheight mul mul translate');
writeln(l);
writeln(l,'  % set the font used in the logos');
writeln(l,'  FontForLogo');
writeln(l,'} def');
writeln(l);

writeln(l,'%(','*[','[ This special comment allows deletion of the repeated');
writeln(l,'% procedures when several logos are concatenated together');
writeln(l,'% See the censor program.');
writeln(l);

writeln(l,'/endpage { % end a page');
writeln(l,'  grestore % ] endpage');
writeln(l,'  showpage % REMOVE FOR PACKAGING INTO ANOTHER FIGURE');
writeln(l,'  restore % ] endpage'); (* required for packaging page *)
writeln(l,'} def');
writeln(l);

writeln(l,'/showleftend {');
writeln(l,'gsave');
writeln(l,' charwidth neg 0 translate');
write  (l,' fivemovex fivemovey moveto');
writeln(l,' ShowEnds (d) eq {(5) show prime} if');
writeln(l,' ShowEnds (p) eq {(N) show} if');
writeln(l,'grestore');
writeln(l,'} def');
writeln(l);

writeln(l,'/showrightend {');
writeln(l,'gsave');
write  (l,' threemovex threemovey moveto');
writeln(l,' ShowEnds (d) eq {(3) show prime} if');
writeln(l,' ShowEnds (p) eq {(C) show} if');
writeln(l,'grestore');
writeln(l,'} def');
writeln(l);

writeln(l,'/startline{ % start a line');
writeln(l,'% move down to the bottom of the line:');
writeln(l,'  0 linemove barheight mul neg translate');
writeln(l,'  gsave % [ startline');

writeln(l,'  % put a bar on the left side:');
writeln(l,'  barends (b) eq barends (l) eq or {');
writeln(l,'    maketic % maketic.startline');
writeln(l,'    gsave');
writeln(l,'      bar2n 0 translate % makebar.startline');
writeln(l,'      makebar % makebar.startline');
writeln(l,'    grestore');
writeln(l,'  } if');
writeln(l,'  showleftend');
writeln(l,'} def');
writeln(l);

writeln(l,'/endline{ % end a line');
writeln(l,'  showrightend');
writeln(l,'  % put a bar on the right side:');
writeln(l,'  barends (b) eq barends (r) eq or {');
writeln(l,'    gsave');
writeln(l,'      bar2 0 translate % makebar.endline');
writeln(l,'      makebar % makebar.endline');
writeln(l,'    grestore');
writeln(l,'  } if');
writeln(l,'  grestore % ] startline');
writeln(l,'} def');

writeln(l);
writeln(l,'% @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@');
writeln(l,'% @@@@@@@@@@@@@@@@@@@@ End of procedures @@@@@@@@@@@@@@@@@@@');
writeln(l,'% @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@');
writeln(l);

writeln(l,'% The following special comment allows deletion of the repeated');
writeln(l,'% procedures when several logos are concatenated together');
writeln(l,'% See the censor program.');
writeln(l,'%]',']%*',')');
writeln(l);

end; end;
(* end module makelogo.p6 *)

(* begin module makelogo.mark.package *)
(******************************************************************************)
(* When transferred to another program, this package
of procedures will do all the mark routines *)

(* begin module makelogo.getmark *)
procedure getmark(var marks, logo: text;
                  var marksymbol: char;
                  var marktype: char;
                  var markbase1, markbits1,
                      markbase2, markbits2,
                      markscale: real;
                  var nextmark: integer;
                  var waitfornextpiece: boolean;
                  var marksorder: char);
(* Obtain the information for placing the next mark (markbase1,markbits1),
its kind (marksymbol) and the integer location (nextmark).  The logo
file is used for user defined symbols.
If waitfornextpiece is true then don't do anything *)
var
   done: boolean; (* done searching for data *)

begin
   done := false;
   if not waitfornextpiece then repeat
      if eof(marks) then begin
         nextmark := maxint;
         marksymbol := ' ';
         done := true;
      end
      else begin
         if eoln(marks) or (marks^=' ') then begin
            readln(marks); (* skip comments.  Allowing a blank character should
               avoid a lot of frustration for people, because otherwise the
               program will halt (see just below) and it is hard to find the
               blank character! *)
            marksymbol := '!'; (* fill with identifiable mark *)
         end
         else begin
            read(marks, marksymbol);
            if not (marksymbol in ['c','b','l','s','t','*','u','U','p','o'])
            then begin
               writeln(output,'mark symbol in file marks',
                              ' must be one of: "cblst*uUpo"');
               writeln(output,'"',marksymbol,'" is not allowed');
               halt
            end;

            if (marksymbol <> '*') and
               (marksymbol <> 'u') and
               (marksymbol <> 'U') and
               (marksymbol <> 'p') and
               (marksymbol <> 'o') then begin
               read(marks, marktype);
               if not (marktype in ['s','f','d'])
               then begin
                  writeln(output,'mark type in file marks',
                                 ' must be one of: "sfd"');
                  writeln(output,'"',marktype,'" is not allowed');
                  writeln(output,'ascii character: ',ord(marktype):1);
                  halt
               end;
            end;

            case marksymbol of
               '*': readln(marks); (* skip comments *)
               'c','t','s': begin
                  readln(marks, markbase1, markbits1, markscale);
                  markbase2 := 0;
                  markbits2 := 0;
                  if markscale <= 0.0 then begin
                     writeln(output,'mark scale must be positive');
                     halt
                  end;
                  nextmark := trunc(markbase1);
                  done := true;
               end;
               'l','b': begin
                  readln(marks, markbase1, markbits1, markbase2, markbits2);
                  nextmark := trunc(markbase1);
                  done := true;
               end;
               'u': begin (* define the user procedure *)

                  while not done do begin
                     if eof(marks) then begin
                        writeln(output,'The "!" to mark the end',
                                       ' of a user defined symbol',
                                       ' in the marks file is missing.');
                        halt
                     end
                     else if marks^<>'!'
                          then copyaline(marks,logo)
                          else done := true;
                  end;
                  readln(marks); (* skip the ! line *)
                  done := false;
               end;
               'U': begin (* grab the coordinates for the user, but DO NOT
                             move to the next line.  Later, in markup, the
                             coordinates in drawing space get calculated and
                             THEN the rest of the line gets copied out *)
                  read(marks, markbase1, markbits1, markbase2, markbits2);
                  nextmark := trunc(markbase1);
                  done := true;
               end;
               'p': begin (* start waiting for next piece *)
                  waitfornextpiece := true;
                  readln(marks);
               end;
               'o': begin (* change overwrite state *)
                  if eoln(marks) then begin
                     writeln(output,'The "o" command must be followed',
                                    ' by a character, bNADF');
                     halt
                  end;
                  readln(marks,marksorder);
               end;
            end;
         end;
      end;
   until done or waitfornextpiece;
end;
(* end module makelogo.getmark version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.marktype *)
procedure makemarktype(var f: text; marktype: char);
(* make the mark type to the file f *)
begin
   case marktype of
      (* for filling, we stroke first!  This ensures that
         the symbol edges are identical whether stroked or not! *)
      'f': writeln(f,' gsave stroke grestore fill');
      's': writeln(f,' stroke');
      'd': writeln(f,' [3] 0 setdash stroke');
   end;
end;
(* end module makelogo.marktype version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.circlesymbol *)
procedure circlesymbol(var f: text; x, y, radius: real; marktype: char);
(* write a circle to file f at (x, y), of given radius
and mark it according to marktype *)
begin
  writeln(f, ' ', x:pwid:pdec,' cm',
             ' ', y:pwid:pdec,' cm',
             ' ', radius:pwid:pdec,' cm',
             ' circlesymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.circlesymbol version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.trianglesymbol *)
procedure trianglesymbol(var f: text; x, y, radius: real; marktype: char);
(* write a triangle to file f at (x, y), of given "radius"
and mark it according to marktype *)
begin
  writeln(f, ' ', x:pwid:pdec,' cm',
             ' ', y:pwid:pdec,' cm',
             ' ', radius:pwid:pdec,' cm',
             ' trianglesymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.trianglesymbol version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.squaresymbol *)
procedure squaresymbol(var f: text; x, y, side: real; marktype: char);
(* write a square to file f at (x, y), of given "side"
and mark it according to marktype *)
begin
  writeln(f, ' ', x:pwid:pdec,' cm',
             ' ', y:pwid:pdec,' cm',
             ' ', side:pwid:pdec,' cm',
             ' squaresymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.squaresymbol version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.linesymbol *)
procedure linesymbol(var f: text; x1, y1, x2, y2: real; marktype: char);
(* write a line to file f at (x1, y1), (x2, y2)
and mark it according to marktype *)
begin
  writeln(f, ' ', x1:pwid:pdec,' cm',
             ' ', y1:pwid:pdec,' cm',
             ' ', x2:pwid:pdec,' cm',
             ' ', y2:pwid:pdec,' cm',
             ' linesymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.linesymbol version = 4.51; (@ of prgmod.p 2000 Nov 1 *)
 
(* begin module makelogo.boxsymbol *)
procedure boxsymbol(var f: text; x1, y1, x2, y2: real; marktype: char);
(* write a box to file f at (x1, y1), (x2, y2)
and mark it according to marktype *)
begin
  writeln(f, ' ', x1:pwid:pdec,' cm',
             ' ', y1:pwid:pdec,' cm',
             ' ', x2:pwid:pdec,' cm',
             ' ', y2:pwid:pdec,' cm',
             ' boxsymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.boxsymbol version = 4.51; (@ of prgmod.p 2000 Nov 1 *)
 
(* begin module makelogo.usersymbol *)
procedure usersymbol(var f: text; x1, y1, x2, y2: real;
                     var marks: text);
(* write a user symbol to file f at (x1, y1), (x2, y2) *)
begin
  writeln(f, ' ', x1:pwid:pdec,' cm',
             ' ', y1:pwid:pdec,' cm',
             ' ', x2:pwid:pdec,' cm',
             ' ', y2:pwid:pdec,' cm ');
  copyaline(marks, f);
end;
(* end module makelogo.usersymbol version = 4.51; (@ of prgmod.p 2000 Nov 1 *)
 
(* begin module makelogo.markup *)
procedure markup(var logo: text;
                     thecharacterwidth: real;
                     cmperbit: real;
                     position: integer;
                 var marks: text;
                 var marksymbol: char;
                 var marktype: char;
                 var markbase1, markbits1,
                     markbase2, markbits2,
                     markscale: real;
                 var nextmark: integer;
                 var waitfornextpiece: boolean;
                 var marksorder: char);
(* markup the logo with the mark as defined by its symbol,
type, coordinate and scale factor. *)
var
   radius: real; (* radius of a circle mark, or the radius of a circle
                    a triangle is enscribed in or the side of a square. *)
   x1: real; (* an x coordinate on the logo *)
   y1: real; (*  a y coordinate on the logo *)
   x2: real; (* an x coordinate on the logo *)
   y2: real; (*  a y coordinate on the logo *)
(* mark the logo up with marks *)
begin
   while (position = nextmark) and
         (not waitfornextpiece)
   do begin
      (* do the mark *)
{
writeln(output,marksymbol,' ',markbase1:5:3, ' ',markbits1:5:3,
                          ' ',markbase2:5:3, ' ',markbits2:5:3,
                          ' ',markscale:5:3,' ',nextmark:5);
}
      writeln(logo,'gsave');

      case marksymbol of
         'c','t','s': begin
            x1 := (markbase1 - nextmark + 0.5) * thecharacterwidth;
            y1 := markbits1 * cmperbit;
            radius := markscale * thecharacterwidth / 2.0;
            case marksymbol of
               'c': circlesymbol(logo,x1,y1,radius,marktype);
               't': trianglesymbol(logo,x1,y1,radius,marktype);
               's': squaresymbol(logo,x1,y1,radius,marktype);
            end;
         end;

         'l','b','U': begin
            x1 := (markbase1 - nextmark + 0.5) * thecharacterwidth;
            y1 := markbits1 * cmperbit;
            x2 := (markbase2 - nextmark + 0.5) * thecharacterwidth;
            y2 := markbits2 * cmperbit;
            case marksymbol of
               'b':  boxsymbol(logo,x1,y1,x2,y2,marktype);
               'l': linesymbol(logo,x1,y1,x2,y2,marktype);
               'U': usersymbol(logo,x1,y1,x2,y2,marks);
            end;
         end;
      end;

      writeln(logo,'grestore');

      (* get the next one *)
      getmark(marks,logo,marksymbol,marktype,
              markbase1,markbits1,markbase2,markbits2,
              markscale,nextmark,waitfornextpiece, marksorder);
   end;
end;
(* end module makelogo.markup version = 4.51; (@ of prgmod.p 2000 Nov 1 *)
 
(* begin module makelogo.marksymbols *)
procedure marksymbols(var l: text);
(* define postscript symbols to file l *)
begin
writeln(l,'/circlesymbol { % x y radius circlesymbol - (path)');
writeln(l,'newpath 0 360 arc closepath} bind def');
writeln(l);

(*
writeln(l,'% axis of triangle for debugging');
writeln(l,'/firstaxis {');
writeln(l,'gsave');
writeln(l,'1 0 0 setrgbcolor');
writeln(l,'newpath 0 0 moveto 100 0 lineto (X) show stroke');
writeln(l,'0 0 moveto 0 50 lineto (Y) show stroke');
writeln(l,'grestore } def');
writeln(l,'/secondaxis {');
writeln(l,'gsave');
writeln(l,'0 1 0 setrgbcolor');
writeln(l,'newpath 0 0 moveto 100 0 lineto (XX) show stroke');
writeln(l,'0 0 moveto 0 50 lineto (YY) show stroke');
writeln(l,'grestore } def');
writeln(l,'/thirdaxis {');
writeln(l,'gsave');
writeln(l,'0 0 1 setrgbcolor');
writeln(l,'newpath 0 0 moveto 100 0 lineto (XXX) show stroke');
writeln(l,'0 0 moveto 0 50 lineto (YYY) show stroke');
writeln(l,'grestore } def');
writeln(l);
*)

writeln(l,'/sqrt3 3 sqrt def');
writeln(l,'/trianglesymbol { % x y radius trianglesymbol - (path)');
writeln(l,'/r exch def');
writeln(l,'/sqrt3r sqrt3 r mul def');
writeln(l,'translate');
(*writeln(l,'% firstaxis'); *)
writeln(l,'120 rotate');
(*writeln(l,'% secondaxis'); *)
writeln(l,'0 r translate');
writeln(l,'-120 rotate');
writeln(l,'newpath');
writeln(l,'0 0 moveto');
writeln(l,'sqrt3r 0 lineto');
writeln(l,'-300 rotate');
(*writeln(l,'% thirdaxis'); *)
writeln(l,'sqrt3r 0 lineto');
writeln(l,'closepath} bind def');
writeln(l);

writeln(l,'/squaresymbol { % x y side squaresymbol - (path)');
writeln(l,'/side exch def');
writeln(l,'translate');
writeln(l,'side 2 div neg dup translate');
writeln(l,'newpath');
writeln(l,'0 0 moveto');
writeln(l,'0 side lineto');
writeln(l,'side side lineto');
writeln(l,'side 0 lineto');
writeln(l,'closepath} bind def');
writeln(l);

writeln(l,'/linesymbol { % x1 y1 x2 y2 linesymbol - (path)');
writeln(l,'/y2 exch def');
writeln(l,'/x2 exch def');
writeln(l,'/y1 exch def');
writeln(l,'/x1 exch def');
writeln(l,'newpath');
writeln(l,'x1 y1 moveto');
writeln(l,'x2 y2 lineto');
writeln(l,'} bind def');
writeln(l);

writeln(l,'/boxsymbol { % x1 y1 x2 y2 boxsymbol - (path)');
writeln(l,'/y2 exch def');
writeln(l,'/x2 exch def');
writeln(l,'/y1 exch def');
writeln(l,'/x1 exch def');
writeln(l,'newpath');
writeln(l,'x1 y1 moveto');
writeln(l,'x2 y1 lineto');
writeln(l,'x2 y2 lineto');
writeln(l,'x1 y2 lineto');
writeln(l,'closepath');
writeln(l,'} bind def');
writeln(l);
end;
(* end module makelogo.marksymbols version = 4.51; (@ of prgmod.p 2000 Nov 1 *)
 
(******************************************************************************)
(* end module makelogo.mark.package version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.startpostscript *)
procedure startpostscript(var l, colors, symvec: text;
                          params: parameters);
(* start the PostScript definitions to file l.
This routine is broken up into a number of separate procedures
to allow translation into C by the p2c program.  If this is not
done, then apparently p2c's memory for literal strings fills up,
and one gets errors like 'segmentation fault'. *)
begin
  p1(l,params);
  p2(l,colors,params);
  p3(l,params);
  p4(l);
  marksymbols(l);
  p4a(l,params);
  p5(l,symvec,params);
  p6(l,params);
end;
(* end module makelogo.startpostscript *)

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

(* begin module softnumbertest *)
function softnumbertest(var f: text): boolean;
(* test that a number follows, but don't die if there is none *)
begin
   skipblanks(f);
   if not (f^ in ['-','+','0','1','2','3','4','5','6','7','8','9']) then begin
(* we can't do this because it would wreck reading parameters
      bar(output,'-');
      writeln(output,'NOTE: in the parameter file,',
        ' another number is now allowed for on this line:');
      copyaline(f,output);
*)
      softnumbertest := false
   end
   else softnumbertest := true
end;
(* end module softnumbertest *)

(* 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 = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module makelogo.readparameters *)
procedure readparameters(var theplace: text; var params: parameters);
(* read in the parameters from the place *)
var
   gotten: boolean; (* if true, we got a user defined string *)
   gottoresetcorner: boolean; (* if true, then reset the xcorner or ycorner
      according to the rotation and base position zerobase *)
   graphshift: real; (* the amount to shift the graph so that it
      is placed with center at zerobase bases *)
   numberstrings: integer; (* the number of strings to read from theplace *)
   n: integer; (* index to numberstrings *)
   spl: integer; (* stacks per line computed *)
   stringspot: stringsptr; (* current spot in thestrings *)
   zerobase: real; (* the zero of the graph in bases *)
procedure cn;
var checkout: boolean; (* if true, all variable values are ok *)
begin
  checkout := checknumber(theplace);
  if not checkout then halt; (* avoid snowballing *)
end;
begin with params do begin
   reset(theplace);
   if not eof(theplace)
   then begin
      cn; readln(theplace, lowest, highest)
   end
   else begin
      writeln(output,'missing all parameters');
      halt
   end;

   if not eof(theplace)
   then begin
      cn; readln(theplace,bar)
   end
   else begin
      writeln(output,'missing bar coordinate parameter');
      halt
   end;

   if not eof(theplace)
   then if theplace^ <> 'z'
        then begin
           cn; readln(theplace, xcorner, ycorner);
           gottoresetcorner := false;
        end
        else begin (* define the zero base of the graph *)
           get(theplace); (* skip the "z" *)
           cn; readln(theplace, xcorner, ycorner, zerobase);
           gottoresetcorner := true;
        end
   else begin
      writeln(output,'missing corner coordinate parameters');
      halt
   end;

   if not eof(theplace)
   then begin
      cn; readln(theplace, rotation)
   end
   else begin
      writeln(output,'missing rotation parameter');
      halt
   end;
   if (round(rotation) mod 90) <> 0 then begin
      writeln(output);
      writeln(output,'WARNING: rotations that are not multiples of');
      writeln(output,'of 90 degrees are likely to be scaled');
      writeln(output,'incorrectly, due to a PostScript limitation.');
      writeln(output,'See the description of the pathbbox function');
      writeln(output,'in the Red book.');
      writeln(output);
   end
   else begin
   end;

   if not eof(theplace)
   then begin
      cn; read(theplace,charwidth);
      (* 2018 Jul 26.  Now read squashspray, see technical notes for details. *)
      squashspray := squashspraydefault; (* set default first *)
{zzzqqq read squashspray}
      skipblanks(theplace);
      if not eoln(theplace) then begin
         if (theplace^ in
            ['0','1','2','3','4','5','6','7','8','9']) then begin
            read(theplace, squashspray);
         end;
      end;
      readln(theplace);
   end
   else begin
      writeln(output,'missing charwidth parameter');
      halt
   end;
   if charwidth <= 0.0 then begin
      writeln(output,'charwidth parameter must be > 0 cm');
      halt
   end;

   (* now that we have character width and rotation we can calculate this: *)
   if gottoresetcorner then begin
      (* note: the 0.5 is half a base so that if zerobase is 0
         the graph centers exactly in the middle of the 0 *)
      graphshift := -charwidth * (zerobase - lowest + 0.5);
{
writeln(output, 'doing gottoresetcorner');
writeln(output, 'lowest     := ',lowest:5:2);
writeln(output, 'zerobase   := ',zerobase:5:2);
writeln(output, 'graphshift := ',graphshift:5:2);
writeln(output, 'rotation   := ',rotation:5:2);
writeln(output, 'OLD xcorner := ',xcorner:5:2);
}
           if abs(rotation) > 135 (*180*) then xcorner := xcorner + graphshift
      else if     rotation  >   0 (*+90*) then xcorner := xcorner - graphshift
      else if     rotation  <   0 (*-90*) then ycorner := ycorner + graphshift
      else     (* rotation  =   0     0*)      xcorner := xcorner + graphshift;
{
writeln(output, 'NEW xcorner := ',xcorner:5:2);
}
   end;

   if not eof(theplace)
   then begin
      cn; readln(theplace,barheight,barwidth)
   end
   else begin
      writeln(output,'missing barheight and barwidth parameters');
      halt
   end;
   if barheight <= 0.0 then begin
      writeln(output,'barheight parameter must be > 0 cm');
      halt
   end;
   if barwidth <= 0.0 then begin
      writeln(output,'barwidth parameter must be > 0 cm');
      halt
   end;

   if not eof(theplace)
   then begin
      cn; readln(theplace,barbits)
   end
   else begin
      writeln(output,'missing barbits parameter');
      halt
   end;
   if barbits < 0.0 then begin
      writeln(output);
      writeln(output,'WARNING: are you SURE you don''t want to show the',
                     ' variation due to a small');
      writeln(output,'number of samples',
                     ' (i.e. the I-beam error bars)?');
      writeln(output);
   end
   else begin
      writeln(output,'* Reminder: the I-beam error bars show the');
      writeln(output,'  variation of the entire stack not just the highest');
      writeln(output,'  symbol, even though it may look like that.');
   end;
   if barbits = 0.0 then begin
      writeln(output,'barbits parameter must not be zero');
      halt
   end;

   (* slip in a new parameter, but do it softly.  That is,
      if the user has a number, the parameter is there and read,
      but if it is not a number, just go on to the next *)
   if softnumbertest(theplace) then begin
      readln(theplace,Ibeamfraction);
      (* Although we could do checks on this, it's fun, and perhaps
         useful to allow the user to put in weird numbers here.  *)
   end
   else Ibeamfraction := 1.0;

   if not eof(theplace)
   then begin
      read(theplace, barends);
      subticsBig   := subticsBigdefault; (* default *)
      subticsSmall := subticsSmalldefault; (* default *)
      if not eoln(theplace) then begin
         read(theplace, ticcommand);
         if ticcommand = 't' then begin
            read(theplace, subticsBig, subticsSmall);
            if subticsBig <= 0 then begin
               writeln(output,'subticsBig is ',subticsBig:1,
                              ' but it must be positive');
               halt
            end;
            if subticsSmall <= 0 then begin
               writeln(output,'subticsSmall is ',subticsSmall:1,
                              ' but it must be positive');
               halt
            end;
         end;
      end;
      readln(theplace);
   end
   else begin
      writeln(output,'barends parameter is missing');
      halt
   end;

   if not eof(theplace)
   then begin
      readln(theplace,showingbox);
   end
   else begin
      writeln(output,'showingbox parameter is missing');
      halt
   end;

   if not eof(theplace)
   then begin
      if theplace^='o' then outline := true
                       else outline := false;
      readln(theplace)
   end
   else begin
      writeln(output,'outline parameter is missing');
      halt
   end;

   if not eof(theplace)
   then begin
      if theplace^='c' then caps := true
                       else caps := false;
      readln(theplace)
   end
   else begin
      writeln(output,'caps parameter is missing');
      halt
   end;

   if not eof(theplace)
   then begin
      cn; readln(theplace,stacksperline);
   end
   else begin
      writeln(output,'stacksperline parameter is missing');
      halt
   end;
   if stacksperline <= 0 then begin
      writeln(output,'stacksperline parameter must be positive');
      halt
   end;

   if not eof(theplace)
   then begin
      cn; readln(theplace,linesperpage);
   end
   else begin
      writeln(output,'linesperpage parameter is missing');
      halt
   end;
   if linesperpage <= 0 then begin
      writeln(output,'linesperpage parameter must be positive');
      halt
   end;

   if linesperpage = 1 then begin
      spl := (highest - lowest + 1);
      if stacksperline <> spl then begin
         writeln(output,'* NOTE: Since there is only one line per page');
         writeln(output,'  requested stacks per line (',stacksperline:1,')');
         writeln(output,'  will be replaced with computed stacks per line (',
                        spl:1,')');
         writeln(output,'  to make centered strings work correctly');
         stacksperline := spl;
      end;
   end;

   if not eof(theplace)
   then begin
      cn; readln(theplace,linemove);
   end
   else begin
      writeln(output,'linemove parameter is missing');
      halt
   end;
   if linemove <= 0 then begin
      writeln(output,'linemove parameter must be positive');
      halt
   end;

   if not eof(theplace)
   then begin
      if theplace^='n' then numbering := true
                       else numbering := false;
      readln(theplace)
   end
   else begin
      writeln(output,'numbering parameters are missing');
      halt
   end;

   if not eof(theplace)
   then begin
      cn; readln(theplace,shrink);
   end
   else begin
      writeln(output,'shrink parameter is missing');
      halt
   end;
   if shrink > 1.0 then begin
      writeln(output,'Shrink parameter must be less than or equal to 1.');
      writeln(output,'This way, you won''t create a misleading logo');
      writeln(output,'which has an apparent height larger than it should.');
      halt;
   end;
   if (shrink > 0.0) and (shrink < 1.0) and (showingbox <> 'b') then begin
      writeln(output,'Shrinking can only be done when showing the box.');
      writeln(output,'This way, you won''t create a misleading logo');
      writeln(output,'which has an apparent height smaller than it should.');
      halt;
   end;
   if (showingbox <> 'b') or (shrink <= 0.0) or (shrink >= 1.0)
   then shrinking := false
   else shrinking := true;

   if not eof(theplace)
   then begin
      cn; readln(theplace,numberstrings)
   end
   else begin
      writeln(output,'number of user defined strings must be given');
      halt
   end;
   if numberstrings > 0 then begin
      new(thestrings);
      stringspot := thestrings;
      for n := 1 to numberstrings do begin
         if eof(theplace) then begin
            writeln(output, 'missing a user defined string coordinate');
            halt;
         end;
         readln(theplace,stringspot^.x, stringspot^.y, stringspot^.s);
         getstring(theplace,stringspot^.astring,gotten);

         write(output,'"');
         writestring(output,stringspot^.astring);
         writeln(output,'"');
         if not gotten then begin
            writeln(output, 'missing a user defined string');
            halt;
         end;
{
write(output,' stringspot^.astring: "');
writestring(output,stringspot^.astring);
writeln(output,'"');
}


         if n < numberstrings
         then begin
            new(stringspot^.next);
            stringspot := stringspot^.next
         end
         else stringspot^.next := nil;
      end
   end
   else thestrings := nil;

   if not eof(theplace)
   then begin
      read(theplace,edgecontrol);
      if edgecontrol <> 'p' then begin
         cn; read(theplace, edgeleft, edgeright, edgelow, edgehigh)
      end
      else begin
         edgeleft := edgemargindefault;
         edgeright := edgemargindefault;
         edgelow := edgemargindefault;
         edgehigh := edgemargindefault;
      end;
      readln(theplace)
   end
   else begin
      edgecontrol := ' ';
      edgeleft := edgemargindefault;
      edgeright := edgemargindefault;
      edgelow := edgemargindefault;
      edgehigh := edgemargindefault;
      writeln(output, 'NOTE:  you can now define the edges,',
                      ' see the documentation.');
      writeln(output, 'Edges are all defaulting to ',
                       edgemargindefault:1,' cm.');
   end;

   if not eof(theplace)
   then begin
      readln(theplace,ShowEnds);
      if (ShowEnds <> 'd') and (ShowEnds <> 'p')
      then ShowEnds := '-'
   end
   else ShowEnds := '-';

   if not eof(theplace)
   then begin
      read(theplace,formcontrol);
      (* equallogo, varlogo, rarelogo *)
      if (not (formcontrol in ['e','v','r','R']))
      then formcontrol := 'n'
   end
   else formcontrol := 'n';

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

(* begin module makelogo.warnifsitesused *)
procedure warnifsitesused(var symvec,fout: text; var sitesused: boolean);
(* 'warn [the user about error bars] if [the] sites [program] was used
[to create the symvec].' *)
var a,b,c,d,e,f,g: char; (* a simple way to do a string *)
begin
   sitesused := false;
   reset(symvec);
   if not eof(symvec) then begin
      readln(symvec); (* skip first line ('* dalvec') *)
      if not eof(symvec) then begin (* determine prior program name *)
         (* check that the string '* sites' exists *)
                  (* *   s i t e s *)
         read(symvec,a,b,c,d,e,f,g);
         if (a = '*') and
            (b = ' ') and
            (c = 's') and
            (d = 'i') and
            (e = 't') and
            (f = 'e') and
            (g = 's') then begin
            writeln(fout,'******************************************',
                         '************************************');
            writeln(fout,'* NOTE: since the data come from the sites',
                         ' program, the error bar is not     *');
            writeln(fout,'* printed on the sequence logo.                 ',
                         '                             *');
            writeln(fout,'******************************************',
                         '************************************');
            sitesused := true;
         end
      end
   end
end;
(* end module makelogo.warnifsitesused *)

(* begin module makelogo.makesymbol *)
procedure makesymbol(var afile: text; height: real;
                     caps: boolean; c: char);
(* write the instructions for the symbol c with height h to file afile.
The move by the amount `height' vertically afterward is done in numchar. *)
const
   (* the value of the threshold is a guess right now! *)
   threshold = 0.00001;
begin
   if abs(height) > threshold then begin
      write(afile,height:pwid:pdec, ' (');
      protectpostscript(afile,c);
      if caps then write(afile,capitalize(c))
              else write(afile,c);
      writeln(afile,') numchar');
   end
end;
(* end module makelogo.makesymbol *)

(* begin module makelogo.Ibeam *)
procedure Ibeam(var afile: text; height: real);
(* write the instructions for making an I beam with height (in cm) to file
afile.  Return to the original coordinate afterwards *)
begin
   writeln(afile,height:pwid:pdec,' Ibeam');
end;
(* end module makelogo.Ibeam *)

(* begin module makelogo.summary *)
procedure summary(var f: text; c: char;
                  rstotal, varhnb: real;
                  thefrom,theto: integer;
                  gaps: integer;
                  density: real);
(* write summary information to file f.  Start each line with character c. *)
begin
if c <> ' ' then write(f,c,' ');
writeln(f,gaps:1, ' gaps in the sequences');
if c <> ' ' then write(f,c,' ');
write  (f,'Rs total is ',rstotal:infofield:infodecim);
if varhnb >= 0 then write(f, ' +/- ',sqrt(varhnb):infofield:infodecim,' bits')
               else write(f, ' bits (sample error not known)');
write(f,' in the range from ',thefrom:1,' to ',theto:1);
{write(f,', d=',density:infofield:infodecim);}
write(f,' d= ',density:1:infodecim);
writeln(f);
end;
(* end module makelogo.summary *)

(* begin module makelogo.makenumber *)
procedure makenumber(var l: text; number: integer);
(* write the PostScript instructions for forming the number in file l *)
begin
  (* allow user to unearth the call to makenumber by hand *)
  write(logo,'numbering {');
  write(l,'(',number:1,') makenumber');
  writeln(logo,'} if');
end;
(* end module makelogo.makenumber *)

(* begin module cosine *)
procedure cosine(var afile: text;
                     amplitude: real;
                     phase: real;
                     wavelength: real;
                     base: real;
                     xmin: real;
                     ymin: real;
                     xmax: real;
                     ymax: real;
                     step: integer;
                     dashon: real;
                     dashoff: real;
                     dashoffset: real;
                     thickness: real);
(* write the cosine wave out to afile as defined by the parameters *)
begin
  writeln(afile, '% amplitude  phase  wavelength  base:');
  writeln(afile, ' ',amplitude:pwid:pdec, ' cm',
                 ' ',phase:pwid:pdec, ' cm',
                 ' ',wavelength:pwid:pdec, ' cm',
                 ' ',base:pwid:pdec, ' cm');
  writeln(afile, '% xmin ymin xmax ymax step:');
  writeln(afile, ' ',xmin:pwid:pdec, ' cm',
                 ' ',ymin:pwid:pdec, ' cm',
                 ' ',xmax:pwid:pdec, ' cm',
                 ' ',ymax:pwid:pdec, ' cm',
                 ' ',step:1);
  writeln(afile, '% dash settings:');
  write  (afile, ' ',dashon:pwid:pdec, ' cm');
  write  (afile, ' ',dashoff:pwid:pdec, ' cm');
  write  (afile, ' ',dashoffset:pwid:pdec, ' cm');
  writeln(afile, ' ',thickness:pwid:pdec, ' cm drawcosine');
end;
(* end module cosine version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module docosinewave *)
procedure docosinewave(var logo: text;{ params: parameters;}
                       wp: waveptr; (* define wave parameters *)
                       charwidth: real; (* width of characters *)
                       cmperbit: real; (* cm per bit *)
                       barheight: real; (* height of wave, cm *)
                       stacknumber: integer;  (* which logo stack we are on,
                          set to 1 if not doing multiple lines *)
                       position: integer); (* position in logo *)
(* overlay a cosine wave as specified by the parameters *)
var
   xscale,yscale: real; (* converstion factors for x and y for the wave *)
   xmin,ymin: real; (* lower left corner the wave could be in, for the wave *)
   xmax,ymax: real; (* upper right corner the wave could be in, for the wave *)
   thiswave: waveptr; (* the wave we are currently printing *)
begin {with params do} begin
   thiswave := wp;
   while thiswave <> nil do with thiswave^ do begin
      xscale := charwidth;
      yscale := cmperbit;
      xmin := (position-stacknumber+1)*xscale; (* position *)
      xmax := (position+1)*xscale; (* position *)
      ymin := 0; (* bits *)
      ymax := waveamplitude + barheight*yscale; (* bits *)
      (* move back to the zero on the plot! *)
      writeln(logo,'gsave');
      writeln(logo,' ',-(position+1)*charwidth:pwid:pdec,
                     ' cm 0 translate');
      if extreme = 'h'
      then cosine(logo, (* high center point cosine wave *)
              +yscale*waveamplitude,             (* amplitude *)
              xscale*(wavelocation+0.5), (* phase *)
              (* the half of a base is to make it put the
                 extreme in the middle of the character rather
                 than between characters *)
              xscale*wavelength,                 (* wavelength (cm) *)
              yscale*(wavebit-waveamplitude),    (* base (cm) *)
              xmin,ymin,xmax,ymax,      (* limiting box (cm) *)
              1, (* step is in points *)
              dashon, (* in cm *)
              dashoff, (* in cm *)
              dashoffset, (* in cm *)
              thickness) (* thickness is in cm *)
      else cosine(logo, (* low center point cosine wave *)
              -yscale*waveamplitude,
              xscale*(wavelocation+0.5),
              xscale*wavelength,
              yscale*(wavebit+waveamplitude),
              xmin,ymin,xmax,ymax,
              1, (* step is in points *)
              dashon, (* in cm *)
              dashoff, (* in cm *)
              dashoffset, (* in cm *)
              thickness); (* thickness is in cm *)
      writeln(logo,'grestore');
      thiswave := thiswave^.next
   end;
end; end;
(* end module docosinewave version = 4.51; (@ of prgmod.p 2000 Nov 1 *)

(* begin module setboundingbox *)
procedure setboundingbox(var logo: text; params: parameters);
(* determine the BoundingBox parameters *)
const
   warnchar = '*'; (* character for warning bar *)
   warnwidth = 70; (* number of characters for warning bar *)
var
   cmfactor: real; (* multiply by this to convert
                      from cm to PostScript points *)
   BaseAxis: real; (* width of the basic logo figure *)
   BitAxis: real; (* height of the basic logo figure *)
   llxhere: real; (* lower left x of figure *)
   llyhere: real; (* lower left y of figure *)
   urxhere: real; (* upper right x of figure *)
   uryhere: real; (* upper right y of figure *)
   srotation: boolean; (* is rotation a member of -90, 0, +90? *)
   pagewarning: boolean; (* Give general warning to use about page problems *)

procedure showbar(n: integer; c: char);
(* show a bar of character c repeated n times to output *)
var count: integer; (* count of the character *)
begin
   for count := 1 to n do begin
      write(output,c);
   end;
   writeln(output);
end;

begin with params do begin
(*
   The original "simple life" method:
   writeln(logo,'%!');
   writeln(logo,'% makelogo ',version:4:2);
*)

   if highest-lowest+1 > stacksperline
   then BaseAxis := charwidth*(stacksperline)
   else BaseAxis := charwidth*(highest-lowest+1);

   BitAxis := barheight*linesperpage*linemove;

   srotation := false;

   if edgecontrol <> 'p' then begin
      cmfactor := 72/2.54; (* convert to points from cm *)
      if round(rotation) = -90 then begin
         llxhere := xcorner;
         llyhere := ycorner - BaseAxis;
         urxhere := xcorner + BitAxis;
         uryhere := ycorner;

         (* expand edge margin and convert to cm *)
         llxhere := (llxhere - edgelow  ) * cmfactor;
         llyhere := (llyhere - edgeright) * cmfactor;
         urxhere := (urxhere + edgehigh ) * cmfactor;
         uryhere := (uryhere + edgeleft ) * cmfactor;

         srotation := true;
      end
      else if round(rotation) = 0 then begin
         llxhere := xcorner;
         llyhere := ycorner;
         urxhere := xcorner + BaseAxis;
         uryhere := ycorner + BitAxis;

         (* expand edge margin and convert to cm *)
         llxhere := (llxhere - edgeleft ) * cmfactor;
         llyhere := (llyhere - edgelow  ) * cmfactor;
         urxhere := (urxhere + edgeright) * cmfactor;
         uryhere := (uryhere + edgehigh ) * cmfactor;

         srotation := true;
      end
      else if round(rotation) = +90 then begin
         llxhere := xcorner - BitAxis;
         llyhere := ycorner;
         urxhere := xcorner;
         uryhere := ycorner + BaseAxis;
         (* expand edge margin and convert to cm *)

         llxhere := (llxhere - edgehigh ) * cmfactor;
         llyhere := (llyhere - edgeleft ) * cmfactor;
         urxhere := (urxhere + edgelow  ) * cmfactor;
         uryhere := (uryhere + edgeright) * cmfactor;

         srotation := true;
      end;

{
      (* expand edge margin and convert to cm *)
      llxhere := (llxhere - edgeleft ) * cmfactor;
      llyhere := (llyhere - edgelow  ) * cmfactor;
      urxhere := (urxhere + edgeright) * cmfactor;
      uryhere := (uryhere + edgehigh ) * cmfactor;
}

      if not srotation then begin
         writeln(output,'* NOTE: The angle of rotation is not a',
                        ' multiple of 90 degrees,');
         writeln(output,'so bounding box is being set to page size.');
      end;
   end;

   if not srotation then begin
      (* force weird values that get corrected to page limits below *)
      llxhere := llx;
      llyhere := lly;
      urxhere := urx;
      uryhere := ury;
   end;

   (* Warn user about weird bounds to the standard page limits *)
   pagewarning := false;
   if llxhere < llx then begin
      showbar(warnwidth, warnchar);
      writeln(output,'* WARNING: left side goes off page');
      pagewarning := true;
   end;
   if llyhere < lly then begin
      showbar(warnwidth, warnchar);
      writeln(output,'* WARNING: lower side goes off page');
      pagewarning := true;
   end;
   if urxhere > urx then begin
      showbar(warnwidth, warnchar);
      writeln(output,'* WARNING: right side goes off page');
      pagewarning := true;
   end;
   if uryhere > ury then begin
      showbar(warnwidth, warnchar);
      writeln(output,'* WARNING: upper side goes off page');
      pagewarning := true;
   end;

   if llxhere >= urxhere then begin
      showbar(warnwidth, warnchar);
      writeln(output,'* WARNING: horizontal bounds of the page are inverted');
      pagewarning := true;
   end;

   if llyhere >= uryhere then begin
      showbar(warnwidth, warnchar);
      writeln(output,'* WARNING: vertical bounds of the page are inverted');
      pagewarning := true;
   end;

   if pagewarning then begin
      writeln(output,'* You have set weird bounds to the standard page limits.');
      writeln(output,'* These limits are defined in the module makelogo.const.');
      writeln(output,'* They are called llx, lly urx and ury, as in PostScript.');
      writeln(output,'* ll is the lower left corner of the display device.');
      writeln(output,'* ur is the upper right corner of the display device.');
      writeln(output,'* See: https://alum.mit.edu/www/toms/postscript.html');
      writeln(output,'* for information about PostScript.  That page describes');
      writeln(output,'* the postscript program printerarea.ps:');
      writeln(output,'* https://alum.mit.edu/www/toms/ftp/printerarea.ps');
      writeln(output,'* That program will report to you the correct values to use');
      writeln(output,'* for your printer.');
      showbar(warnwidth, warnchar);
   end;

   (* create header for EPS file *)
   writeln(logo,'%!PS-Adobe-2.0 EPSF-2.0');
   writeln(logo,'%%Title: makelogo ',version:4:2);
   writeln(logo,'%%Creator: Tom Schneider, toms@alum.mit.edu');
   (* NOTE: bounding box definition (Red book page 284) requires
      integers, so the values are rounded just before output: *)
   writeln(logo,'%%BoundingBox:',
             ' ',round(llxhere):5,
             ' ',round(llyhere):5,
             ' ',round(urxhere):5,
             ' ',round(uryhere):5);
   writeln(logo,'%%Pages: atend');
   writeln(logo,'%%DocumentFonts:');
   writeln(logo,'%%EndComments');

   writeln(logo,'/llx ',llxhere:5:1,' def');
   writeln(logo,'/lly ',llyhere:5:1,' def');
   writeln(logo,'/urx ',urxhere:5:1,' def');
   writeln(logo,'/ury ',uryhere:5:1,' def');
end; end;
(* end module setboundingbox *)

(* begin module themain *)
procedure themain(var symvec, makelogop, colors, marks, wave,
                  logo: text);
(* the main procedure of the program *)

var
   params: parameters; (* the parameters read from makelogop *)

   actualsymbols: integer; (* the sum of the actual number of symbols found in
     symvec, as opposed to nl, the number that is SUPPOSED to be there *)
   b: integer; (* index to a symbol *)
   chilogo: boolean; (* if true, this is a chilogo *)
   density: real; (* information density of the displayed logo *)
   dobeam: boolean; (* true means we are going to write the Ibeam *)
   dostack: boolean; (* true means we are going to write a stack of letters *)
   fbl: real; (* frequency of symbol b at position l *)
   gaps: integer; (* number of positions with no sequence *)
   letter: char; (* a letter in the alphabet test *)
   l: integer; (* predicted coordinate *)
   linenumber: integer; (* number of lines of logo printed so far *)

   markbase1: real; (* location in bases of the marksymbol or its start *)
   markbase2: real; (* location in bases of the marksymbol end *)
   markbits1: real; (* location in bits of the marksymbol or its start *)
   markbits2: real; (* location in bits of the marksymbol end *)
   markscale: real; (* factor by which to change the size of the marksymbol *)
   marksymbol: char; (* a symbol to mark on the logo *)
   marktype: char; (* how to mark a symbol on the logo: dash, fill, stroke *)
   marksorder: char; (* order of writing marks *)
   nextmark: integer; (* the position to place the next mark *)
   waitfornextpiece: boolean; (* wait for next piece of DNA before doing the
                                 next mark *)
      (* Note: there is no next piece - this is for compatability with
         lister and other programs that use marks on multiple pieces *)

   nl: integer; (* number of symbols at position l *)
   pagenumber: integer; (* page number we are beginning to write out *)
   position: integer; (* a location in the aligned sequence (true coordinate) *)
   previousposition: integer; (* the previous value of position *)
   rsl: real; (* information at position l *)
   rsvar: real; (* variance of information at position l *)
   rstotal: real; (* sum of the rsl for the whole logo *)
   varhnb: real; (* variance of rstotal for the whole logo *)
   sitesused: boolean; (* true if the sites program was used to create the
      data.  This determines whether an obnoxious warning should be put
      into the logo ... *)
   stacknumber: integer; (* the number of the stack of symbols.  Unlike the
      position variable, it begins at 1.  It is used to decide when to break
      the logo onto the next line *)

{
This is moved to the global parameters
   symbols: integer; (* number of symbols possible *)
}

   mapbb: char; (* for reading map parts *)
   mapbn: integer; (* for reading map parts *)

begin (* themain *)
   writeln(output,'makelogo ',version:4:2);
   (* reset all input files first so if one is missing
      the logo file hasn't been destroyed yet. *)
   reset(symvec);
   reset(makelogop);
   reset(colors);
   reset(marks);
   reset(wave);
   marksorder := 'b';
   gaps := 0;

   readparameters(makelogop,params);

with params do begin (* do the regular logo *)
   cmperbit := barheight / abs(barbits); (* converts bits to cm *)

   reset(wave);
   if eof(wave)
   then wp := nil
   else readwaveparameters(wave,wp);
{
   else readwaveparameters(wave,wp, charwidth (* cmperbase *), cmperbit);
}


   warnifsitesused(symvec,output,sitesused);

   if eof(colors) and (not outline) then begin
      writeln(output,'Half-White Ibeams are used because',
                     ' the symbols are solid black.');
      HalfWhiteIbeam := true
   end
   else HalfWhiteIbeam := false;

   rewrite(logo);

   setboundingbox(logo, params);

   reset(symvec);
   if not eof(symvec) then begin
      while symvec^='*' do begin
         write(logo,'% ');
         copyaline(symvec,logo);
      end;
      readln(symvec,symbols);
      writeln(output,'* ',symbols:1,' symbols.');
   end;
   pagenumber := 0;
   startpostscript(logo,colors,symvec, params);

   nextmark := maxint;
   waitfornextpiece := false;
   getmark(marks,logo,marksymbol,marktype,
           markbase1,markbits1,markbase2,markbits2,
           markscale,nextmark,waitfornextpiece, marksorder);

   reset(symvec);
   if eof(symvec) then begin (* do an alphabetic test logo *)
      writeln(output,'* Alphabet Logo created because symvec is empty.');
      writeln(logo,'% Alphabet Logo');
      writeln(logo,'startpage startline');
      if (barends='b') or (barends='l') or (barends = 'r')
      then writeln(logo,'makebar');
      writeln(logo,'% find out how high the bar is in centimeters:');
      writeln(logo,'/barincm barheight cmfactor div def');
      for b := ord('A') to ord('Z') do begin
         position := b - ord('A') + 1;
         if position = bar then writeln(logo,'makebar');
         if (position >= lowest) and (position <= highest)
         then begin
            makenumber(logo,position);
            if not caps then letter := chr(b - ord('A') + ord('a'))
                        else letter := chr(b);
            writeln(logo,'  gsave barincm (',letter,')',
                          ' numchar grestore shift');
         end;
      end;
      if (barends='b') or (barends='l') or (barends = 'r')
      then writeln(logo,'makebar');
      writeln(logo,'endline endpage');
   end
   else begin (* do the regular logo *)
      (* the main loop; read through the symvec, sort the characters and then
         create the graphic.
         The program originally assumed that the header of symvec has
         been skipped and that symbols is read in already.  However,
         doing it again is safer, given that symvec can now be read
         by other parts of the program. *)

      processsymvec(symvec);
      readln(symvec); (* skip symbols *)

      rstotal := 0.0;
      varhnb := 0.0;
      linenumber := 0; (* trigger start of a page *)
      l := lowest;
      position := lowest;
      chilogo := false;
      while not eof(symvec) do begin
         previousposition := position; (* keep track of previous position *)
         processsymvec(symvec);

         readln(symvec,position,nl,rsl,rsvar);
         if nl = 0 then begin
{writeln(output,'nl = 0'); halt;}
            gaps := succ(gaps);
         end;

{
         if rsl < lowestRsl then rsl := lowestRsl;
         if rsl < lowestRsl then rsl := 0;
}
{mmm}

         (* read through the symbols and see if they are really all there.
         This check is useful when someone writes a symvec themselves. *)
         actualsymbols := 0;
         for b := 1 to symbols do begin
            processsymvec(symvec);

            (* The GPC compiler points out that for:
            readln(symvec,map[b].b, map[b].n);
            error: this use of packed array components is an extension of
            error:  Borland Pascal, traditional Macintosh Pascal
            So read the two parts in and assign. *)
            readln(symvec,mapbb, mapbn);
            map[b].b := mapbb;
            map[b].n := mapbn;

            if map[b].n < 0 then if not chilogo then begin
               chilogo := true;
               writeln(output,'This is a Chilogo! - Upside down letters',
                              'will be produced');
            end;
            if chilogo
            then actualsymbols := actualsymbols + abs(map[b].n)
            else actualsymbols := actualsymbols + map[b].n
         end;
         if ((not chilogo) and (nl <> actualsymbols)) or
            (chilogo and (abs(nl - actualsymbols) > 1.5 )) then begin
            (* in the case of the chilogo, the sum of rounded numbers
               may be off by 1 *)
            writeln(output);
            writeln(output,'THE SYMVEC FILE IS BAD!');
            writeln(output,'At position ',position:1,
                           ' the sum of symbols found is ',actualsymbols:1);
            writeln(output,'But the noted number is ',nl:1);
            halt
         end;

         (* create the PostScript code for this stack of symbols *)
         if (position >= lowest) and (position <= highest)
         then begin

            rstotal := rstotal + rsl;
            varhnb := varhnb + rsvar;

            (* put the symbols into order of their frequency *)
            quicksort(1,symbols);

            (* track the line number *)
            if linenumber = 0 then begin
               pagenumber := pagenumber + 1;
               if pagenumber = 1
               then writeln(logo,'%%EndProlog')
               else writeln(output,'writing page ',pagenumber:1);

               writeln(logo);
               writeln(logo,'%%Page: ',pagenumber:1,' ',pagenumber:1);
               writeln(logo,'startpage % [');

               stacknumber := 0; (* trigger line to start *)
            end;

            (* track the number of stacks on the line *)
            if stacknumber = 0 then begin
               linenumber := linenumber + 1;
               writeln(logo,'startline % line number ',linenumber:1);
            end;
            stacknumber := stacknumber + 1;

            if position = bar
            then if    (barends='b') or (barends='l') or (barends = 'r')
                    or (stacknumber <> 1)
            then begin
               writeln(logo,'% before coordinate ',position:1,': make the bar');
               writeln(logo,'makebar');
            end;

            writeln(logo,'% at coordinate ',position:1);
            makenumber(logo,position);

            (* avoid plotting tiny Rs values at all (PostScript blows up
               on the Apple LaserWriter - and no plot comes out.) *)
{mmm}
{
            (* unearth this write statement to determine the minimum *)
writeln(output,     round(pnum* 0.00005 *cmperbit):20,
               ' ', round(pnum* 0.00005 *cmperbit));
}
            if round(pnum*rsl*cmperbit) > minimumStackSize
            then dostack := true
            else dostack := false;

            (* if rsvar is negative, this indicates that the
               sample variation is unknown.  (see the sites.p program) *)
            dobeam := false;
            if rsvar >= 0.0
            then begin
               if barbits > 0.0 then dobeam := true
            end
            else if not sitesused then begin
               writeln(output, 'WARNING: a negative Rs variation was');
               writeln(output, 'found in symvec, but the data are not from');
               writeln(output, ' the sites program.');
               writeln(output, 'There may be a program or data error.');
            end;

            if formcontrol in ['e', 'R'] then begin
               (* override and do stack! *)
               dostack := true;
               dobeam := false; (* no I beam *)
            end;

            if dostack or dobeam then writeln(logo,'gsave');
            if dostack then begin
               for b := 1 to symbols do begin
                  (* draw one character in the stack of characters *)
                  fbl := map[b].n / nl;
                  showletter := true;
{
formcontrol := 'R';
formcontrol := 'n';
formcontrol := 'r';
}
                  case formcontrol of
                     'n': begin (* normal logo *)
                          stackheight := rsl;
                          symbolheight := fbl;
                     end;
                     'v': begin (* varlogo *)
                          stackheight :=
                             ln(symbols)/ln(2) (* equallogo height*)
                             -
                             rsl;
                          symbolheight := fbl;
                     end;
                     'e': begin (* equallogo *)
{zzzbbb}
                          stackheight := 1;
                          symbolheight := fbl* ln(symbols)/ln(2);
{
                          stackheight := ln(symbols)/ln(2); OLD no!!
                          symbolheight := fbl; OLD
                          symbolheight := fbl; OLD
}
{
writeln(output,'BUBBA     symbols = ',symbols:1);
writeln(output,'BUBBA stackheight = ',stackheight:2:1);
writeln(output,'BUBBA         fbl = ',        fbl:5:2);
writeln(output,'BUBBA  showletter = ',        showletter);
}
                     end;
                     'r': begin (* rarelogo *)
                          stackheight := rsl;
                          symbolheight := (1-fbl)/(symbols-1);
                          showletter := (fbl > 0.0);
                     end;
                     'R': begin (* rarelogo, equal heights *)
                          stackheight := ln(symbols)/ln(2);
                          symbolheight := (1-fbl)/(symbols-1);
                          showletter := (fbl > 0.0);
                     end;
                  end;
                  if showletter
                  then makesymbol(logo, round(pnum
                                   *symbolheight*stackheight
                                   *cmperbit)/abs(pnum),
                                   caps, map[b].b)
                  else makesymbol(logo, round(pnum
                                   *symbolheight*stackheight
                                   *cmperbit)/abs(pnum),
                                   caps, '.');
{zzz}
                  (* note: the abs(pnum) makes sure that the sign of pnum
                     DOES get passed to makesymbol, so that upside down
                     symbols can be printed! *)
               end;
            end;
            if dobeam and (not sitesused) then Ibeam(logo,sqrt(rsvar)*cmperbit);
            if dostack or dobeam then writeln(logo,'grestore');

            (* make the appropriate marks within this base interval *)
            (* Since sequence logo positions are always increasing, if the
               next mark is less than the current position, we would not see
               any marks from this point on.  So move nextmark up to position
               to ensure that we see them.  This makes the markup routine
               compatable with the lister program.  1999 Mar 5 *)
            if nextmark < position then nextmark := position;
            markup(logo,charwidth,cmperbit,position,
                   marks,marksymbol,marktype,
                   markbase1,markbits1,markbase2,markbits2,
                   markscale,nextmark,waitfornextpiece,marksorder);

            writeln(logo,'shift'); (* move away from this stack *)
            if (stacknumber = stacksperline) or (position=highest)
            then docosinewave(logo,
                              params.wp,
                              params.charwidth,
                              params.cmperbit,
                              params.barheight,
                              stacknumber, position);

            if (linenumber = linesperpage) and
               (stacknumber = stacksperline) then begin (* complete the page *)

               if highest = bar - 1
               then if (barends='b') or (barends='l') or (barends = 'r')
               (* or (stacknumber <> 1) residue from main call *)
               then begin
                  writeln(logo,'% bar at end of logo:',
                               ' make the bar before position ',
                                position:1);
                  writeln(logo,'makebar');
               end;

               writeln(logo,'endline');
               stacknumber := 0; (* trigger for restarting the line *)
               writeln(logo,'endpage % ]');
               linenumber := 0; (* trigger for restarting the page *)
            end;

            if stacknumber = stacksperline then begin (* complete the line *)
               writeln(logo,'endline');
               stacknumber := 0; (* trigger for restarting the line *)
            end;

            (* check that the coordinate system has a zero base *)
            (* WARNING: IT IS FORBIDDEN TO REMOVE OR MODIFY THIS SECTION OF
            CODE TO ALLOW STUPID NUMBERING SYSTEMS THAT GO -2, -1, +1, +2! *)
            while (l <> position) and (l <= highest) do begin
               writeln(output);
               writeln(output,'WARNING: symvec does not contain data for',
                              ' position ',l:1);
               if (l = 0) and (lowest < 0) and (highest > 0) and
                  (position = 1) and (previousposition = -1) then begin
                  writeln(output,'It seems that you don''t have a zero',
                                 ' coordinate.');
                  writeln(output,'"... the invention, probably by the',
                                 ' Hindus, of the digit zero has been');
                  writeln(output,'described as one of the greatest',
                                 ' importance in the history of mathematics."');
                  writeln(output,'--- Encyclopaedia Britannica (1:1175, 1982)');
                  writeln(output);
                  writeln(output,'Please use a zero!');
                  writeln(output);
                  writeln(output,'A zero coordinate is necessary for');
                  writeln(output,'identifying the location of a binding site');
                  writeln(output,'with a walker (NAR 25:4408-4415 (1997).');
                  writeln(output,'If you remove the zero it will make life');
                  writeln(output,'much more difficult later.');
                  writeln(output);
                  rewrite(logo);
                  halt
               end;

               writeln(output);
               l := l + 1; (* predict the next position *)
            end;
            l := l + 1; (* predict the next position *)
         end;
      end;

      if position < highest then begin
         writeln(output);
         writeln(output,'WARNING: Highest position requested was not found',
                        ' in symvec');
         writeln(output);
         (* in this case, the cosine wave was not done above, so do it now *)
         if stacknumber <> 0
         then docosinewave(logo,
                           params.wp,
                           params.charwidth,
                           params.cmperbit,
                           params.barheight,
                           stacknumber, position);

      end;

      (* make sure that the end line and page is done! *)
      if stacknumber <> 0 then writeln(logo,'endline');
      if linenumber  <> 0 then writeln(logo,'endpage % ]');

      density := rstotal/(2*((highest - lowest + 1) - gaps));
      summary(logo,  '%',rstotal,varhnb,lowest,highest, gaps, density);
      summary(output,' ',rstotal,varhnb,lowest,highest, gaps, density);

   end;
   writeln(logo,'%%Trailer');
   writeln(logo,'%%Pages: ',pagenumber:1);
end; (* end of with for parameters *)
end;
(* end module themain *)

begin
   themain(symvec, makelogop, colors, marks, wave, logo);
1: end.
