program makelogo(symvec, makelogop, colors, marks, wave, logo, output); (* makelogo: make a graphical `sequence logo' for aligned sequences Thomas D. Schneider, Ph.D. National Institutes of Health National Cancer Institute Gene Regulation and Chromosome Biology Laboratory Molecular Information Theory Group Frederick, Maryland 21702-1201 schneidt@mail.nih.gov toms@alum.mit.edu (permanent) http://alum.mit.edu/www/toms (permanent) module libraries required: delman, prgmods *) label 1; (* end of program *) const (* begin module version *) version = 9.49; (* of makelogo.p 2012 Apr 19 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 line 6: barheight barwidth: (real, > 0) height of the vertical bar, in cm, and its width, in cm. 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. Thes are the same size as the numbered tics. subticsSmall is the number of intervals for small subtics. Thes 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. 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 Times-BoldItalic font, but leave "38" and "LexA binding sites" in Times-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 n: normalogo. standard sequence logo (or any other character) v: varlogo. See discussion below. 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. 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 is a NEW parameter: 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:} http://alum.mit.edu/www/toms/icons/lexa-logo.gif http://alum.mit.edu/www/toms/icons/donor.pure.gif {A Gallery of Sequence Logos:} http://alum.mit.edu/www/toms/sequencelogo.html {Glossary definition of Sequence Logo:} http://alum.mit.edu/www/toms/glossary.html#sequence_logo {-----------------------} {FORM CONTROL FOR SEQUENCE LOGOS} {controlled by parameter formcontrol} {Normal logo (normallogo):} {Note: the sine wavelength is 3.6 amino acids, corresponding to an alpha helix.} http://alum.mit.edu/www/toms/makelogo/normallogo.gif {Variable logo (varlogo):} {Plot Hafter(l) instead of R(l).} http://alum.mit.edu/www/toms/makelogo/varlogo.gif {Equal logo (equallogo):} {Equal stack heights. Note that sequence conservation data is lost.} http://alum.mit.edu/www/toms/makelogo/equallogo.gif {Rare logo: (rarelogo):} {Plot 1-Pi instead of Pi. Normal stack heights} http://alum.mit.edu/www/toms/makelogo/rarelogo.gif {Rare-Equal logo: (rareequallogo):} {Plot 1-Pi instead of Pi, equal stack heights.} http://alum.mit.edu/www/toms/makelogo/rareequallogo.gif {-----------------------} {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:} http://www.lecb.ncifcrf.gov/~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:} http://www.lecb.ncifcrf.gov/~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. National Institutes of Health National Cancer Institute Gene Regulation and Chromosome Biology Laboratory Molecular Information Theory Group Frederick, Maryland 21702-1201 schneidt@mail.nih.gov toms@alum.mit.edu (permanent) http://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.Stephens.Logo, author = "T. D. Schneider and R. M. Stephens", title = "Sequence Logos: A New Way to Display Consensus Sequences", journal = "Nucl. Acids Res.", volume = "18", pages = "6097-6100", year = "1990"} Use of wave: @article{Papp.helixrepa, 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.", comment = "Cover of 233, number 2!", volume = "233", pages = "219-230", year = "1993"} Dirty DNA synthesis experiments: @article{Schneider1989, author = "T. D. Schneider and G. D. Stormo", title = "Excess Information at Bacteriophage {T7} Genomic Promoters Detected by a Random Cloning Technique", year = "1989", journal = "Nucl. Acids Res.", volume = "17", pages = "659-674"} 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 Times-Bold and the second in Times-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. *) (* 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} (* 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 *) 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 f: frequencies v: varlogo 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 (http://www.lecb.ncifcrf.gov/~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 = 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 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); } (* 2007 Jan 10 Bug solution: spaces are zeros below the decimal! *) if c =' ' then c := '0'; if (c <> '+') then putchar(c); 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; 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 putchar(curr); 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 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); 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); 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'); writeln(l,'/FontForStringRegular {/Times-Bold ffss} def'); writeln(l,'/FontForStringItalic {/Times-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,' visible {'); writeln(l,' % implement boxes, fill and characters:'); writeln(l,' showingbox (s) eq'); writeln(l,' showingbox (f) eq'); writeln(l,' or'); writeln(l,' {gsave'); writeln(l,' ly lx'); writeln(l,' ly charwidth add'); writeln(l,' lx charheight add'); writeln(l,' boxsymbol'); writeln(l,' clip'); 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' on the left *) writeln(l,'gsave'); 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; readln(theplace,charwidth) 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.'); 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.'); 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,'"'); {BUBBA} 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: http://www.lecb.ncifcrf.gov/~toms/postscript.html'); writeln(output,'* for information about PostScript. That page describes'); writeln(output,'* the postscript program printerarea.ps:'); writeln(output,'* ftp://ftp.ncifcrf.gov/pub/delila/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@ncifcrf.gov'); (* 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 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 *) stackheight := ln(symbols)/ln(2); symbolheight := fbl; 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.