/* Output from p2c 1.21alpha-07.Dec.93, the Pascal-to-C translator */
/* From input file "delila.p" */


#include <p2c/p2c.h>


/* lll ccc */

/* delila: the librarian for sequence manipulation
         by Thomas Schneider
            Gary Stormo
            Paul Morrissett
            useful suggestions by Jeff haemer

         module libraries needed: delman, delmods.

  Dr. Thomas D. Schneider
  National Cancer Institute
  Laboratory of Experimental and Computational Biology
  Frederick, Maryland  21702-1201
  toms@ncifcrf.gov
  permanent email: toms@alum.mit.edu (use only if first address fails)
  http://www.lecb.ncifcrf.gov/~toms/

 */

/* label ******************************************************************/
/* end of the program used in procedure halt only */

/* constants **************************************************************/
/* begin module version */

#define version         4.89
/* of delila.p 2007 Dec 06
2007 Dec 06: 4.89; always reduce coordinates if the piece is circular
2005 Sep  6: 4.88; demote error 220 to a warning: deleting a whole
                sequence merely means not to put it in the book!
                Implement by not writing to the book ...
2005 Jan 11: 4.87; cleanup
2005 Jan 11: 4.86; long names cause infnite loop
                in irlongname this was missing:
                longname^.next := nil;
2004 Jan 21: 4.85; finish up marks.
2004 Jan 21: 4.84; cleanup
2004 Jan 21: 4.83; gpctime.p upgrade.  compiles but gives segmentation fault!
                needed to set pk^.dna := nil; libpie^.dna := nil;
2004 Jan 21: 4.82; marks. arrow -> marks.arrow
2003 Aug 18: 4.81; halt message includes the name 'delila'
2003 Apr  7: 4.80; bug fix - request for change before start of piece now ok.
2002 Apr 17: 4.79; tab and other odd ASCII characters disallowed: error 33.
2001 Oct  5: 4.78; mutations off piece are now warnings, not errors (215, 216)
2001 Mar 28: 4.77; pass 2 errors written independently of pass 1
2001 Mar 28: 4.75; bug: two titles bombs!
2001 Mar 16: 4.74; clean up
2001 Mar 16: 4.73; gene functions; specpiece must use libpie not pk!
2001 Mar 16: 4.72; upgrade bug documentation (gene no longer functions)
2000 Nov 15: 4.70; catch unclosed comments
2000 Oct 26: 4.69; set maximum book size
2000 Oct 18: 4.67; stmts w/o with still trigger marksdelila stepping
2000 Oct 18: 4.66; upgrade to gpc
2000 Oct 17: 4.63; 'direction + with a4021131c[cr]; caused parse bomb.
2000 Oct 17: 4.62; blank after 'direction +' caused parse bomb.
2000 Aug 17: 4.60; fixed withused bug; marksdelila only written in pass 2
2000 July 12: 4.59; withused control: marksdelila not touched unless needed.
2000 June 21: 4.58; upgrade the See Also section.
2000 May 26: 4.55; allow inserts to be complemented. zzz111
2000 May 25: 4.54; Fix insertion bug in complements (proc. changesequence)!
2000 May 25: 4.53; Remove duplication of error reports to output.
2000 Mar 29: 4.52; Report error numbers to output, saves checking listing.
2000 January 3: 4.50; {} comments for the html links
2000 January 3: 4.49; html link for delila instructions
1999 August 17: 4.48; changes not noted
1999 July 17: 4.47: Add message You_need_a_marks.arrow_definition to marksdelila
                 file so user will see this if they forget.
1999 July 13: 4.46: putbase, getbase etc now allow any length in each
                 dnasegment - much more robust.
1999 July 9: 4.20: bug fix in getdnasegment dnamax could not be small
                (b and bDNAptr need to be stepped if they exceed dnamax)
1999 May 27: 4.07: user does not propagate coordinates
1999 May 24: 4.03: mutations cannot overlap - makes all marks work!
                not implemented - need other changes first
1999 May 23: 4.00: a26g works as t26c on the complement
1999 May 14: 3.76: <INSERTION> and <DELETION> always are in increasing
                order, following the new definition in Libdef.
1999 May 12: 3.66: new comment type, {}
1999 May 11: 3.56: ability of insertion/deletions to wrap around
1999 May 10: 3.50: upgraded error reporting for incorrect change commands.
1999 May 6: 3.21:  added errors 215, 216; moved mutation routines
                below geteoinst so error output is cleaner.
1999 May 5: 3.17:  fix delila position misreading
1999 April 27: 3.10:  fix memory leak in circledna/invert
1999 April 26: 3.06:  fix bug in: get from 6 to 1 with i4,3ggttgg;
1999 April 15: 3.03:  fix bug in: get from 1 to 6 with i3,4ggttgg;
1999 April 14: 3.00: allow insert off ends of piece (fix bug)
1999 April 14: 2.99: fixed equalname: need to set i initially
1999 April 13: 2.98: fixed memory leak
1999 March 21: 2.90: marks are sorted so most displays will work.
1999 March 21: 2.85: Synonymes: default = set
1999 March 20: 2.84: Delila can now create mutation marks for lister!
1999 March 19: 2.70: Delila can now create mutations!
1999 March 17: 2.61: For completeness, Delila can now extract a single base
  from the complementary strand, as in "get from 1 to 1 direction -;"
1999 March 14: 2.44: dopiece functions entirely on internal variables!
1999 March 13: 2.40: conversion to standard delmod book reading routines.
1999 Mar 9: 2.34 The catal file gives a line number that each object starts
  on.  The bookreading routine getto used to get to the line after the
  start of an object, and the routines like brdna, brpiece, getocp all
  took this into account.  To make it more clear, getto in delmod and here
  now gets to the start of the object.  The routines that then read the
  object may readln past the start if they want.
1999 Mar 9: 2.31 Convert to standard book reading routings:  Procedure
  dopiece needs to read in the dna, make mutations, clip out the relevant
  part and then spit it out to the book.  It needs to keep track of
  library lines if the catal is to be of any use.  But the standard book
  reading routine brpiece does not track the lines read.  Therefore it was
  necessary to alter delmod.p so that the standard book reading routines
  keep track of the line number.  This was done.
1999 Mar 6: Delila absored the mutation mechanism from dbmutate.  Not
         functional yet because it needs to read pieces in standard way.
1998 June 24: default coordinate 0 was being set in pass 1 but not
  reset to normal at the start of pass 2.
1998 January 26: namelength set to 100 to allow long names
1998 January 4: dnamax set to 10 million for faster grabs
1997 January 10: For convenience, the default is: only pieces are numbered.
1996 September 2: Two reductions off end of piece is now flagged.
1996 August 12: introduction of 'same'.
1995 December 7: objects can now be named in the long name
1995 Nov 13: default coordinate zero now allows default coordinate (number)
last changes: 1989 November 14
origin: 1980 or so */
/* end module version */

/* begin module describe.delila */
/*
name
   delila: the librarian for sequence manipulation

synopsis
   delila(inst: in, book: out, listing: out,
          marksdelila: out,
          lib1: in, cat1: in,
          lib2: in, cat2: in,
          lib3: in, cat3: in,
          output: out, debug: out)

files
   inst: instructions written in the language delila that tell the
      program delila what sequences to pull out of the library.

   book: the set of sequences pulled out of the library.

   listing: the instructions are listed along with errors found or
      actions taken.

   marksdelila: Colored marks for the lister program that indicate
      the locations of base changes, insertions and deletions.

   lib1: the first library from which to obtain sequences
   cat1: the first catalogue, corresponding to lib1
   lib2: the second library
   cat2: the second catalogue, corresponding to lib2
   lib3: the third library
   cat3: the third catalogue, corresponding to lib3

   debug: traces through the actions taken, for debugging delila
      (only produced if variable debugging is true.)

   output: messages to the user

description

   Delila is a data base manager for nucleic acid sequences.  It takes a set
   of instructions, written in the language delila (DEoxyribonucleic acid
   LIbrary LAnguage) and a large set of sequences called a library.  The
   output is a listing of the actions taken (or errors) corresponding to the
   instructions, and a "book" containing the sequences desired.

examples
   see the documentation

documentation
   libdef (defines delila), delman.intro, delman.use, delman.construction
   philgen.ps

see also

   {Definition of the database system:}
   libdef

   {Introduction to Delila Instructions:}
   http://www.lecb.ncifcrf.gov/~toms/delilainstructions.html

   {Related programs:}
   alist.p, catal.p, loocat.p, dbbk.p, lister.p

   dbmutate.p {is deprecated: use the mutation method, 'with'}

   {(} http://www.m-w.com/cgi-bin/dictionary?deprecated {)}

author
   Thomas D. Schneider, Gary D. Stormo and Paul Morrisett
   useful suggestions by Jeff Haemer

bugs

   There used to be many known bugs in delila, related to extracting linear
   fragments of circular sequences.  Delila was rebuilt in the spring of 1999
   and is much more robust now.

   The following features are not available in this program:  recognition
   classes and enzymes, markers, automatic printing to the book of structures
   that intersect a piece, get all (for org, chr, rec and enz), get every and
   if.  The gene mechanism was revived on 2001 Mar 16, eventually it may be
   used to implement features.

   Delila programs use a packed array of bases.  This means that a smart
   Pascal compiler can store DNA sequences in two bits per base.  When delila
   was originally designed, I thought that everybody would complete their
   sequences and therefore there would never be unknown bases in a database.
   Silly me.  GenBank has plenty of such cases.  The dbbk program avoids this
   problem by converting such bases to 'a'.  Fortunately these can now be
   displayed with lister.  Someday Delila may be upgraded to handle this
   case, but it might be at the cost of reducing the maximum sequence that
   can be handled.

*/
/* end module describe.delila */

/*
files used:
      inst = instructions
      book = the book that is printed
      listing = instruction listing
      lib1,lib2,...numlibfil = the files of the library
      cat1,cat2,...numcatfil = the files of the catalogue
      debug = listing for debugging the code
      output = for fatal error messages to the terminal

procedure name conventions:
      cr catalogue read
      ir instruction read
      lr library read
      bw book write


   flow of information in the librarian
   [file name]  (procedure)

 [library]      [catalogue]  [instructions]
      :              :           :
      v              v           v
      :              :           :
      :          (catalogue      :
      :          procedures)     :
      :              :           :
      :....... ......:           :
             : :                 :
            (lr"s)           (ir"s)
              :                  :
              v                  v
              :                  :
              :  ................:
              :  :
              :  :
            (delila)
              :  :
              v  v
              :  :
       .......:  :................
       :                         :
       :                       (ir"s)
     (bw"s)                (writeerror"s)
       :                   (writevalue"s)
       :                         :
       v                         v
       :                         :
    [book]                    [listing]


      further documentation for this program is in:
      'organism and recognition class library definition:
       a dna sequence data base' 1980 june 9

      note.. the following features are not yet available in this program:
      recognition class and enzymes
      markers
      automatic printing to the book of structures that intersect a piece
      get all (for org, chr, rec and enz)
      get every
      if

      lll = places that must be changed when one changes the number of
         library files: numlibfil
      ccc = places that must be changed when one changes the number of
         catalogue files: numcatfil
*/

#define numlibfil       3   /* number of library files lll */
#define numcatfil       3   /* number of catalogue files ccc */

#define namelength      100   /* maximum key name length */
#define linelength      200   /* maximum line readable in library */

#define dnamax          1024
    /* maximum bases of dna in a part of a dna string */

/* (60 bits/word)*(1base/2bits)*100 words=3000 bases */
/* 1998 Jan 4: set to 10 million bytes - why not?? */
/* 1999 Jul 7: 10 thousand bytes - ran out of memory! */
#define dnalinemax      60   /* bases of dna per line written in the book */

#define sitemax         20   /* bases of a site in a part of a site string */
/* (60 bits/word)*(1 sitebase/3bits) * (1 word) = 20 sitebases */

#define maxstep         10
    /* the maximum number of steps of the traversal chart */

#define instwidth       6   /* width of left edge numbers on the listing */

#define decbase         2
    /* number of decimal places for bases in marksdelila */
#define widbase         6   /* width of places for bases in marksdelila */
#define decbits         2
    /* number of decimal places for bits in marksdelila */
#define widbits         6   /* width of places for bits in marksdelila */

#define maxbook         LONG_MAX   /* maximum book size */

/* begin module datetime.const */

#define datetimearraylength  19
/* length of dataarray for dates,
    It is just long enough to include the 4 digit year - solving the
    year 2000 problem:
1980/06/09 18:49:11
123456789 123456789
      1         2
*/
/* end module datetime.const version = 'cdatemod.p 1.19 1999Dec13'; */

/* begin module changeset.const */
#define changesetmax    20   /* maximum number of changes allowed */
#define insertmax       1000   /* maximum insertion length allowed (bp) */


/* end module changeset.const version = 1.89; (@ of dbmutate.p 1999 April 26 */

/* types *****************************************************************/

/* the nodes in the library tree */
typedef enum {
  libnode, orgnode, chrnode, marnode, mardnanode, tranode, gennode, pienode,
  piednanode, recnode, enznode, sitenode
} node;
/* step is the sequence of characters that must be printed in the
   book to go from one node to another */
typedef Char step[maxstep];

/* begin module book.type ****************/
/* types needed for book manipulations */

typedef long chset[5];


/* types defined in book definition */

typedef Char alpha[namelength];   /* this is not alfa */

/* name is a left justified string with blanks following the
   characters */

typedef struct name {
  alpha letters;
  /* zero means an unspecified structure */
  char length;
} name;

typedef struct line {
  /* a line of characters */
  Char letters[linelength];
  uchar length;
  struct line *next;
} line;

typedef enum {
  plus, minus, dircomplement, dirhomologous
} direction;
typedef enum {
  linear, circular
} configuration;
typedef enum {
  on, off
} state;

typedef struct header {
  /* header of key */
  name keynam;   /* key name of structure */
  line *fulnam;   /* full name of structure */
  /* note key */
  line *note;
} header;

/* begin module base.type */
/* define the four nucleotide bases */
typedef enum {
  a, c, g, t
} base;
/* end module base.type version = 7.52; {of delmod.p 2000 Jul 30} */

/* sequence types */
typedef short dnarange;

/* p2c: delila.p, line 387:
 * Note: Field width for seq assumes enum base has 4 elements [105] */
typedef uchar seq[(dnamax + 3) / 4];

typedef struct dnastring {
  seq part;
  dnarange length;
  struct dnastring *next;
} dnastring;


typedef struct orgkey {
  /* organism key */
  header hea;
  /* genetic map units */
  line *mapunit;
} orgkey;

typedef struct chrkey {
  /* chromosome key */
  header hea;
  double mapbeg;   /* number of genetic map beginning */
  /* number of genetic map ending */
  double mapend;
} chrkey;

typedef struct piekey {
  /* piece key */
  header hea;
  double mapbeg;   /* genetic map beginning */
  configuration coocon;   /* configruation (circular/linear) */
  direction coodir;   /* direction (+/-) relative to genetic map */
  long coobeg;   /* beginning nucleotide */
  long cooend;   /* ending nucleotide */
  configuration piecon;   /* configruation (circular/linear) */
  direction piedir;   /* direction (+/-) relative to coordinates */
  long piebeg;   /* beginning nucleotide */
  long pieend;   /* ending nucleotide */
} piekey;


typedef struct piece {
  piekey key;
  dnastring *dna;
} piece;

typedef struct reference {
  name pienam;   /* name of piece referred to */
  double mapbeg;   /* genetic map beginning */
  direction refdir;   /* direction relative to coordinates */
  long refbeg;   /* beginning nucleotide */
  long refend;   /* ending nucleotide */
} reference;

typedef struct genkey {
  /* gene key */
  header hea;
  reference ref;
} genkey;

typedef struct trakey {
  /* transcript key */
  header hea;
  reference ref;
} trakey;

typedef struct markey {
  /* marker key */
  header hea;
  reference ref;
  state sta;
  line *phenotype;
  struct marker *next;
} markey;

typedef struct marker {
  markey key;
  dnastring *dna;
} marker;

/* end module book.type version = 7.52; {of delmod.p 2000 Jul 30} */


/* types defined in library definition that are not in the standard
   book reading routines */

typedef struct reckey {
  /* dna recognition class key */
  header hea;
} reckey;

typedef struct enzkey {
  /* enzyme key */
  header hea;
} enzkey;

typedef enum {
  sa, sc, sg, st, pu, py, sn, modification, cleaveage, unknown, alternative
} sitebase;

typedef struct sitestring {
  /* a single recognition site */
/* p2c: delila.p, line 478:
 * Note: Field width for part assumes enum sitebase has 11 elements [105] */
  uchar part[(sitemax + 1) / 2];
  char length;
  /* pointer to another recognition site */
  struct sitestring *next;
} sitestring;

/* c) storage of the recognition of a dna sequence */

typedef struct enzyme {
  enzkey key;
  sitestring *sites;
} enzyme;

/* default types */

typedef struct defaultkey {
  /* to print the key or not to print the key */
  state note;   /* note */
  state mar;   /* marker */
  state gen;   /* gene */
  /* transcript */
  state tra;
} defaultkey;

typedef struct defaultsite {
  /* to act on the site or not to act on the site */
  state expand;   /* expand sites */
  state modify;   /* modify sites */
  state cleave;   /* cleave sites */
} defaultsite;

/* how to act when a request is out of range: */
typedef enum {
  rreduce, rcontinue, rhalt
} rangeaction;

typedef enum {
  orgnum, chrnum, marnum, tranum, gennum, pienum, recnum, enznum
} numberedstructure;

typedef struct defaultnumber {
  state sta;   /* whether or not to number in the book */
  state str[8];   /* what can be numbered */
  long item;   /* the next item"s number */
} defaultnumber;

/* coordinate type: */
typedef enum {
  coornormal, coorzero
} coordinatetype;

typedef struct default_ {
  defaultkey key;
  defaultsite sit;
  rangeaction defout;   /* odd name to get around sun4 bug... */
  defaultnumber num;
  coordinatetype coo;
  state doubling;   /* whether to make two pieces when mutating */
  double arrowlength;   /* length of mark arrow in lines */
} default_;

/* catalogue types */

typedef struct item {
  /* an item in the catalogue */
  Char letter;   /* type of structure */
  name nam;   /* the structure"s key name */
  /* location of the structure in the library */
  long line_;
} item;

typedef struct catfile {
  FILE *f;
  FILEBUFNC(f,item);
  Char name[_FNSIZE];
} catfile;

/* begin module datetime.type */
/* array for dates */
typedef Char datetimearray[datetimearraylength];
/* end module datetime.type version = 'cdatemod.p 1.19 1999Dec13'; */

/* begin module delila.changeset.type */

typedef struct changedata {
  Char changetype;
      /* the type of change: c(hange), i(nsertion), d(eletion) */
  Char baseold;   /* the old base given in a change instruction */
  Char basenew;   /* the new base given in a change instruction */
  long basecoo1;   /* the first coordinate, external coordinates */
  long basecoo2;   /* the second coordinate, external coordinates */
  long internal1;   /* the first coordinate, internal coordinates */
  long internal2;   /* the second coordinate, internal coordinates */
  boolean insertasdeletion;   /* insertion is acting as a deletion */
  /*dddDDDddd*/
  long inserts;   /* number of bases to insert */
  Char insert[insertmax];   /* bases to insert */
  /*zzz111*/
  boolean insertcomplement;
      /* insert the complement of the typed sequence */
} changedata;

typedef struct changeset {
  /* the complete set of changes for an entry */
  changedata data[changesetmax];
  long number;   /* number of changes */
} changeset;

/* from changeset.type version = 1.89; (@ of dbmutate.p 1999 April 26 */
/* end module delila.changeset.type */

/* variables **************************************************************/


/* file variables */
Static _TEXT lib1, lib2, lib3;   /* lll */
Static catfile cat1, cat2, cat3;   /* ccc */
Static _TEXT inst, listing, book, marksdelila, debug;

Static long libline[numlibfil];   /* location in the libfiles */
Static long firstlibrary;
/* the first library used.  this is the one
   from which the parent date of the book originates in bwbookheader */

Static boolean versioninbook;
/* this variable allows delila to write
   its version into the book after the first organism name */

/* time variables */
Static datetimearray datetime;   /* date of book withdrawal */

/* catalogue search varibles */
Static char catnumber;   /* number of catfile being searched */
Static long catline[numcatfil];   /* line in the catfile */
Static long currento, currentc, currentr, currentl;
/* the line in the current catalogue of the previously found
   organism, recognition site, chromosome or other key name */
Static boolean itemfound;   /* whether the requested item was found or not */

/* default variables */
Static default_ def;   /* all of the default variables */
Static numberedstructure indnum;   /* an index for def.num.str */

/* traverse tree variables */
/* the traversal chart defines how one can move around the library tree.
   some "steps" are illegal (illegaltraversal).  the others are the first
   characters of words to be printed in the book between nodes of the tree */
Static step traversalchart[12][12];
Static step illegaltraversal;
Static node pastlibrary;   /* the currently specified node from the library */
Static node pastbook;   /* the currently specified node for the book */
Static node pastcheck;   /* node for instruction checking */
Static Char nodechar[12];   /* the characters for each node */
Static Char nodeletter;   /* the current node character */

Static boolean debugging;   /* for debugging purposes */

Static boolean withused;
/* set true if the 'with' command was used.
   This determines whether we need to write the marksdelila file */

Static long booksize;
    /* current size of book in bases to compare to maxbook */

/* begin module book.var */
/* ************************************************************************ */
/* global variables needed for book manipulations */

/* free storage: */
Static line *freeline;   /* unused lines */
Static dnastring *freedna;   /* unused dnas */

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

/* ************************************************************************ */
/* end module book.var version = 7.52; {of delmod.p 2000 Jul 30} */

/* free storage for unimplemented functions */
Static marker *freemarker;   /* unused markers */
Static sitestring *freesite;   /* unused sites */

/* character reading variables */
Static Char ch;   /* spare character */
Static Char firstch;   /* first character of each library line */
Static Char blank;   /* second character of each library attribute */
Static boolean skipping;
/* whether to skip the first two characters
                  of a library line in routine skipstar */

/* memory of DNA and piece key information in the library */
Static piece *libpie;   /* the entire piece as recorded in the library */
Static item libpieit;
/* used to record the location of the dna of a piece
                  in the library */
Static long libpiefi;   /* file for libpieit */

/* who points where
      lineptrs point to a linked list of lines

      markers point to a linked list of markers, with one (or few) pieces
      of dna per marker

      pieces point to a linked list of dna strings

      dnaptrs point to a linked list of dnastrings

      enzymes point to a linked list of sites

      siteptrs point to a linked list of sites
*/

/* variable for creating zeroed coordinate system */
Static long zerobase, zeroshift;
    /* amount to shift away from zero coordinate */
Static long zeroBS;   /* sum of zerobase and zeroshift, for efficiency */

/* variables to handle the NAME to be given to the next long name */
Static line *longname;   /* the longname for the next object */
Static boolean longnameexists;   /* true if a longname was read */

/* variables for mutating sequences */
Static changeset mutations;
Static long mutposition1;   /* error: mutation position 1 */
Static long mutposition2;   /* error: mutation position 2 */
Static Char mutnotchar;   /* error: what the mutation character is not */
Static Char mutischar;
    /* error: what the mutation character or command is */
Static changedata mutcd1, mutcd2;   /* changes to a sequence */

/* variable to remember last piece to avoid rereading it if we can.
The mechanism will reread if the org/chr is respecified or we star
pass 2. */
Static name lastpiecename;

/* variables for making marksdelila file */
Static double insertupperbits;   /* upperbits for insertion symbol */
Static double insertlowerbits;   /* lowerbits for insertion symbol */
Static double deleteupperbits;   /* upperbits for deletion symbol */
Static double deletelowerbits;   /* lowerbits for deletion symbol */
Static double changeupperbits;   /* upperbits for change symbol */
Static double changelowerbits;   /* lowerbits for change symbol */


/* begin module crash */
Static Void crash()
{
  /* Crash the program by trying to open a nonexistant file.  This allows
tracing by the dbx program.  To use:  insert call into the halt program
or whereever a traceable stop is desired. */
  _TEXT bogus;   /* boghous internal file */

  bogus.f = NULL;
  *bogus.name = '\0';
  printf(" program crash.\n");
  if (*bogus.name != '\0')
    bogus.f = fopen(bogus.name, "r");
  else
    rewind(bogus.f);
  if (bogus.f == NULL)
    _EscIO2(FileNotFound, bogus.name);
  RESETBUF(bogus.f, Char);
  fclose(bogus.f);
}


Static jmp_buf _JL1;


/* end module crash version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module halt */
Static Void 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. */
  printf(" program halt.\n");
  longjmp(_JL1, 1);
}


/* end module halt version = 1.08; (@ of gpctime.p 2004 Jan 21 */

/**************************************************************************/
/**************************************************************************/
/**************************************************************************/

/* begin module package.getpiece */
/* ************************************************************************ */
/* begin module package.brpiece */
/* ************************************************************************ */
/* begin module book.basis */
/* procedures needed for book manipulations */

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

Static Void getline(l)
line **l;
{
  /* obtain a line from the free line list or by making a new one */
  if (freeline != NULL) {
    *l = freeline;
    freeline = freeline->next;
  } else
    *l = (line *)Malloc(sizeof(line));
  (*l)->length = 0;
  (*l)->next = NULL;
}


Static Void getdna(l)
dnastring **l;
{
  if (freedna != NULL) {
    *l = freedna;
    freedna = freedna->next;
  } else
    *l = (dnastring *)Malloc(sizeof(dnastring));
  (*l)->length = 0;
  (*l)->next = NULL;
}


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

Static Void clearline(l)
line **l;
{
  /* return a line to the free line list */
  line *lptr;

  if (*l == NULL)
    return;
  lptr = *l;
  *l = (*l)->next;
  lptr->next = freeline;
  freeline = lptr;
}


Static Void writeline(afile, l, carriagereturn)
_TEXT *afile;
line *l;
boolean carriagereturn;
{
  /* write a line to a file, with carriage return if
carriagereturn is true. */
  long index;   /* index to characters in l */
  long FORLIM;

  FORLIM = l->length;
  for (index = 0; index < FORLIM; index++)
    putc(l->letters[index], afile->f);
  if (carriagereturn)
    putc('\n', afile->f);
}


Static Void showfreedna()
{
  /* show the freedna list */
  long counter = 0;   /* count of freedna list */
  dnastring *l;   /* pointer into freedna list */

  l = freedna;
  while (l != NULL) {
    counter++;
    printf("%ld", counter);
    printf(", length = %d\n", l->length);
    /*
This is illegal according to gpc because one cannot
write a pointer to a text file.  It can be unearthed
for debugging.
          write(output, ', pointer id: ',l:1);
    */
    l = l->next;
  }
}


Static Void cleardna(l)
dnastring **l;
{
  dnastring *lptr;

  if (*l == NULL)
    return;
  lptr = *l;
  *l = (*l)->next;
  lptr->next = freedna;
  freedna = lptr;
}


Static Void clearheader(h)
header *h;
{
  /* clear the header h (remove lines to free storage) */
  clearline(&h->fulnam);
  while (h->note != NULL)
    clearline(&h->note);
}


Static Void clearpiece(p)
piece **p;
{
  /* clear the dna of the piece */
  while ((*p)->dna != NULL)
    cleardna(&(*p)->dna);
  clearheader(&(*p)->key.hea);
}


Static base chartobase(ch)
Char ch;
{
  /* convert a character into a base */
  base Result;

  switch (ch) {

  case 'a':
    Result = a;
    break;

  case 'c':
    Result = c;
    break;

  case 'g':
    Result = g;
    break;

  case 't':
    Result = t;
    break;
  }
  return Result;
}


Static Char basetochar(ba)
base ba;
{
  /* convert a base into a character */
  Char Result;

  switch (ba) {

  case a:
    Result = 'a';
    break;

  case c:
    Result = 'c';
    break;

  case g:
    Result = 'g';
    break;

  case t:
    Result = 't';
    break;
  }
  return Result;
}


Static base complement(ba)
base ba;
{
  /* take the complement of ba */
  base Result;

  switch (ba) {

  case a:
    Result = t;
    break;

  case c:
    Result = g;
    break;

  case g:
    Result = c;
    break;

  case t:
    Result = a;
    break;
  }
  return Result;
}


Static Char chomplement(b)
Char b;
{
  /* create the character complement of base b.  I must be getting hungry! */
  return (basetochar(complement(chartobase(b))));
}


Static long pietoint(p, pie)
long p;
piece *pie;
{
  /* p is a coordinate on the piece.
     we want to transform p into a number
     from 1 to n: an internal coordinate system for
     easy manipulation of piece coordinates */
  long i;   /* an intermediate value */
  piekey *WITH;

  WITH = &pie->key;
  switch (WITH->piedir) {

  case plus:
    if (p >= WITH->piebeg)
      i = p - WITH->piebeg + 1;
    else
      i = p - WITH->coobeg + WITH->cooend - WITH->piebeg + 2;
    break;

  case minus:
    if (p <= WITH->piebeg)
      i = WITH->piebeg - p + 1;
    else
      i = WITH->cooend - p + WITH->piebeg - WITH->coobeg + 2;
    break;
  }
  return i;
}


Static long inttopie(i, pie)
long i;
piece *pie;
{
  /* i is in the range 1 to some maximum.  it is an internal coordinate
     system for the program.  we want to do a
     coordinate transformation to obtain
     a value in the range of the piece called pie:
     i=1 corresponds to piebeg and
     i=its maximum corresponds to pieend */
  long p;   /* an intermediate value */
  piekey *WITH;

  WITH = &pie->key;
  switch (WITH->piedir) {

  case plus:
    p = WITH->piebeg + i - 1;
    if (p > WITH->cooend) {
      if (WITH->coocon == circular)
	p += WITH->coobeg - WITH->cooend - 1;
    }
    break;

  case minus:
    p = WITH->piebeg - i + 1;
    if (p < WITH->coobeg) {
      if (WITH->coocon == circular)
	p += WITH->cooend - WITH->coobeg + 1;
    }
    break;
  }
  return p;
}


Static long piecelength(pie)
piece *pie;
{
  /* return the length of the dna in pie */
  return (pietoint(pie->key.pieend, pie));
}


/* end module book.basis version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.getto */
Static Char getto(thefile, theline, ch)
_TEXT *thefile;
long *theline;
long *ch;
{
  /* search the file for a character in the first line which is a
     member of the set ch.
Note:  on 1999 March 10 the definition of this function was cleaned
up.  Instead of putting thefile on the line AFTER the charcter ch
has been found, it puts thefile ON the line.  Other routines like
brdna and brpiece have to move to the next line themselves.  This makes
getto give the OBJECT.  */
  Char achar = ' ';   /* a character in thefile */
  boolean done = false;   /* done finding achar */

  while (!done) {
    if (BUFEOF(thefile->f)) {
      done = true;
      break;
    }
    achar = P_peek(thefile->f);
    if (P_inset(achar, ch)) {
      done = true;
      break;
    }
    fscanf(thefile->f, "%*[^\n]");
    getc(thefile->f);
    (*theline)++;
  }
  if (P_inset(achar, ch))
    return achar;
  else {
    return ' ';
    /* The old method -
          while (not(achar in ch)) and (not eof(thefile))
             do begin
                readln(thefile,achar);
                theline := succ(theline)
             end;
       if (achar in ch) then getto:=achar
                        else getto:=' '
    */
  }
}


/* end module book.getto version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.skipstar */
Static Void skipstar(thefile)
_TEXT *thefile;
{
  /* skip start of line (or star = '*'). */
  if (BUFEOF(thefile->f)) {
    printf(" procedure skipstar: end of book found\n");
    halt();
    return;
  }
  if (P_peek(thefile->f) != '*') {
    printf(" procedure skipstar: bad book\n");
    printf(" \"*\" expected as first character on the line, but \"%c\" was found\n",
	   P_peek(thefile->f));
    halt();
  }
  getc(thefile->f);   /* skip the star */
  if (P_peek(thefile->f) != ' ') {   /* skip the blank */
    printf(" procedure skipstar: bad book\n");
    printf(" \"* \" expected on a line but \"*%c\" was found\n",
	   P_peek(thefile->f));
    halt();
  }
  getc(thefile->f);
}  /* skipstar */


/* end module book.skipstar version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brreanum */
Static Void brreanum(thefile, theline, reanum)
_TEXT *thefile;
long *theline;
double *reanum;
{
  /* read a real number from the file */
  skipstar(thefile);
  fscanf(thefile->f, "%lg%*[^\n]", reanum);
  getc(thefile->f);
  (*theline)++;
}


/* end module book.brreanum version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brnumber */
Static Void brnumber(thefile, theline, num)
_TEXT *thefile;
long *theline, *num;
{
  /* read a number from the file */
  skipstar(thefile);
  fscanf(thefile->f, "%ld%*[^\n]", num);
  getc(thefile->f);
  (*theline)++;
}


/* end module book.brnumber version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brname */
Static Void brname(thefile, theline, nam)
_TEXT *thefile;
long *theline;
name *nam;
{
  /* read a name from the file */
  long i;   /* an index to the name */
  Char c_;   /* a character read */

  skipstar(thefile);
  nam->length = 0;
  do {
    nam->length++;
    c_ = getc(thefile->f);
    if (c_ == '\n')
      c_ = ' ';
    nam->letters[nam->length - 1] = c_;
  } while (!(P_eoln(thefile->f) || nam->length >= namelength ||
	     nam->letters[nam->length - 1] == ' '));
  if (nam->letters[nam->length - 1] == ' ')
    nam->length--;
  if (nam->length < namelength) {
    for (i = nam->length; i < namelength; i++)
      nam->letters[i] = ' ';
  }
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
  (*theline)++;
}  /* brname */


/* end module book.brname version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brline */
Static Void brline(thefile, theline, l)
_TEXT *thefile;
long *theline;
line **l;
{
  /* read a line from the file */
  long i = 0;
  Char acharacter;

  skipstar(thefile);
  while (!P_eoln(thefile->f)) {
    i++;
    acharacter = getc(thefile->f);
    if (acharacter == '\n')
      acharacter = ' ';
    (*l)->letters[i-1] = acharacter;
  }
  (*l)->length = i;
  (*l)->next = NULL;
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
  (*theline)++;
}


/* end module book.brline version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brdirect */
Static Void brdirect(thefile, theline, direct)
_TEXT *thefile;
long *theline;
direction *direct;
{
  /* read a direction */
  Char ch;

  skipstar(thefile);
  fscanf(thefile->f, "%c%*[^\n]", &ch);
  getc(thefile->f);
  if (ch == '\n')
    ch = ' ';
  (*theline)++;
  if (ch == '+')
    *direct = plus;
  else
    *direct = minus;
}


/* end module book.brdirect version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brconfig */
Static Void brconfig(thefile, theline, config)
_TEXT *thefile;
long *theline;
configuration *config;
{
  /* read a configuration */
  Char ch;

  skipstar(thefile);
  fscanf(thefile->f, "%c%*[^\n]", &ch);
  getc(thefile->f);
  if (ch == '\n')
    ch = ' ';
  (*theline)++;
  if (ch == 'l')
    *config = linear;
  else
    *config = circular;
}


/* end module book.brconfig version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brnotenumber */
Static Void brnotenumber(thefile, theline, note)
_TEXT *thefile;
long *theline;
line **note;
{
  /* book note reading to obtain the number of the object.
the procedure returns the value of the number as a global.
(this is not such a good practice, but we are stuck with it for now.) */
  *note = NULL;
  numbered = false;
  number = 0;
  /* force number to zero if there
     is no number at all */
  /* the next character is n or * depending on whether there are notes */
  if (P_peek(thefile->f) != 'n')
    return;
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
  (*theline)++;
  if (P_peek(thefile->f) != 'n') {
    skipstar(thefile);
    if (!P_eoln(thefile->f)) {
      if (P_peek(thefile->f) == '#') {
	numbered = true;
	getc(thefile->f);   /* move past the number symbol */
	fscanf(thefile->f, "%ld", &number);
      }
    }
    do {
      fscanf(thefile->f, "%*[^\n]");
      getc(thefile->f);
      (*theline)++;
    } while (P_peek(thefile->f) != 'n');
    fscanf(thefile->f, "%*[^\n]");
    getc(thefile->f);
    (*theline)++;
    return;
  }
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
  (*theline)++;
}  /* brnotenumber */


/* end module book.brnotenumber version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brnote */
Static Void brnote(thefile, theline, note)
_TEXT *thefile;
long *theline;
line **note;
{
  /* read note key */
  line *newnote;   /* the new note */
  line *previousnote;   /* the last line of the notes */

  *note = NULL;
  if (P_peek(thefile->f) != 'n')  /* enter note */
    return;
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
  (*theline)++;
  if (P_peek(thefile->f) != 'n') {  /* abort null note (n/n) */
    getline(note);
    newnote = *note;
    while (P_peek(thefile->f) != 'n') {  /* wait until end of note */
      brline(thefile, theline, &newnote);
      previousnote = newnote;
      /* get next note */
      getline(&newnote->next);
      newnote = newnote->next;
    }
    /* last note was not used, so: */
    clearline(&newnote);
    previousnote->next = NULL;
    fscanf(thefile->f, "%*[^\n]");
    getc(thefile->f);
    (*theline)++;
    return;
  }
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
  (*theline)++;
}  /* brnote */


/* end module book.brnote version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brheader */
Static Void brheader(thefile, theline, hea)
_TEXT *thefile;
long *theline;
header *hea;
{
  /* read the header of a key. */
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
      /* move past the object name - new definition 1999 Mar 13 */
  (*theline)++;
  /*bbb*/
  /* read key name */
  brname(thefile, theline, &hea->keynam);

  /* read full name */
  getline(&hea->fulnam);
  brline(thefile, theline, &hea->fulnam);

  /* read note key */
  if (readnumber)
    brnotenumber(thefile, theline, &hea->note);
  else
    brnote(thefile, theline, &hea->note);
}


/* end module book.brheader version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.copyheader */
Static Void copyheader(fromhea, tohea)
header fromhea, *tohea;
{
  /* copy the header fromhea into tohea.  Note that the
linked objects are NOT copied, but merely pointed to. */
  memcpy(tohea->keynam.letters, fromhea.keynam.letters, sizeof(alpha));
  tohea->keynam.length = fromhea.keynam.length;
  tohea->note = fromhea.note;
  tohea->fulnam = fromhea.fulnam;
}


/* end module book.copyheader version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brpiekey */
Static Void brpiekey(thefile, theline, pie)
_TEXT *thefile;
long *theline;
piekey *pie;
{
  /* read piece key, track the line number */
  brheader(thefile, theline, &pie->hea);
  brreanum(thefile, theline, &pie->mapbeg);
  brconfig(thefile, theline, &pie->coocon);
  brdirect(thefile, theline, &pie->coodir);
  brnumber(thefile, theline, &pie->coobeg);
  brnumber(thefile, theline, &pie->cooend);
  brconfig(thefile, theline, &pie->piecon);
  brdirect(thefile, theline, &pie->piedir);
  brnumber(thefile, theline, &pie->piebeg);
  brnumber(thefile, theline, &pie->pieend);
}


/* end module book.brpiekey version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brdna */
Static Void brdna(thefile, theline, dna)
_TEXT *thefile;
long *theline;
dnastring **dna;
{
  /* read in dna from thefile, track the line */
  /* note: if the dna were circularized, by linking the last dnastring
to the first, then the cleardna routine could not clear properly,
and would loop forever... there is no reason to do that, since a simple
mod function will allow one to access the circle. */
  Char ch;
  dnastring *workdna;
  long SET[5];
  long TEMP;

  getdna(dna);
  workdna = *dna;
  ch = getto(thefile, theline, P_addset(P_expset(SET, 0L), 'd'));
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
  (*theline)++;
  ch = getc(thefile->f);   /* skipstar */
  if (ch == '\n')
    ch = ' ';
  while (ch == '*') {
    ch = getc(thefile->f);   /* skip blank */
    if (ch == '\n')
      ch = ' ';
    do {
      ch = getc(thefile->f);
      if (ch == '\n')
	ch = ' ';
      if (ch == 't' || ch == 'g' || ch == 'c' || ch == 'a') {
	if (workdna->length == dnamax) {
	  getdna(&workdna->next);
	  workdna = workdna->next;
	}
	workdna->length++;
	TEMP = workdna->length - 1;
	P_clrbits_B(workdna->part, TEMP, 1, 3);
	P_putbits_UB(workdna->part, TEMP, (int)chartobase(ch), 1, 3);
      }
    } while (!P_eoln(thefile->f));
    fscanf(thefile->f, "%*[^\n]");
    getc(thefile->f);   /* go to next line */
    (*theline)++;
    ch = getc(thefile->f);   /* ch is either '*' or 'd' */
    if (ch == '\n')
      ch = ' ';
  }
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);   /* read past the d */
  (*theline)++;
}


/* end module book.brdna version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brpiece */
Static Void brpiece(thefile, theline, pie)
_TEXT *thefile;
long *theline;
piece **pie;
{
  /* read in a piece, change theline to reflect the lines traversed */
  /*
     readln(thefile); (* move past the word 'piece' - new definition 1999 Mar 13 *)
     theline := succ(theline); (* BUG: was below! *)
bbb*/
  brpiekey(thefile, theline, &(*pie)->key);
  if (numbered || !skipunnum)
    brdna(thefile, theline, &(*pie)->dna);
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
      /* move past the word 'piece' - new definition 1999 Mar 13 */
  (*theline)++;
}


/* end module book.brpiece version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brinit */
Static Void brinit(book, theline)
_TEXT *book;
long *theline;
{
  /* check that the book is ok to read, and
     set up the global variables for br routines */
  /* halt if the book is bad (first word is 'halt') or the first
     character is not * */
  if (*book->name != '\0') {
    if (book->f != NULL)
      book->f = freopen(book->name, "r", book->f);
    else
      book->f = fopen(book->name, "r");
  } else
    rewind(book->f);
  if (book->f == NULL)
    _EscIO2(FileNotFound, book->name);
  RESETBUF(book->f, Char);
  if (!BUFEOF(book->f)) {
    /* check for the date line */
    if (P_peek(book->f) != '*') {
      if (P_peek(book->f) != 'h')
	printf(" this is not the first line of a book:\n");
      else
	printf(" bad book:\n");
      putchar(' ');

      while (!(P_eoln(book->f) | BUFEOF(book->f))) {
	putchar(P_peek(book->f));
	getc(book->f);
      }
      putchar('\n');
      halt();
    }
  } else {
    printf(" book is empty\n");
    halt();
  }

  /* initialize free storage */
  freeline = NULL;
  freedna = NULL;

  readnumber = true;   /* usually we read in numbers for items */
  number = 0;   /* arbitrary value */
  numbered = false;   /* the piece has no number (none yet read in) */
  skipunnum = false;
  *theline = 1;
}  /* brinit */


/* end module book.brinit version = 7.52; {of delmod.p 2000 Jul 30} */

/* ************************************************************************ */
/* end module package.brpiece version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.getpiece */
Static Void getpiece(thefile, theline, pie)
_TEXT *thefile;
long *theline;
piece **pie;
{
  /* move to and read in the next piece in the book */
  Char ch;
  long SET[5];

  ch = getto(thefile, theline, P_addset(P_expset(SET, 0L), 'p'));
      /* get to the next p(iece) in the book */
  if (ch != ' ') {
    brpiece(thefile, theline, pie);
    /*
1999 june 2: removed this:
          ch:=getto(thefile,theline,['p']); (* read to end of p *)
    */
    /*
bbb - now done in brpiece
          readln(thefile); (* read past piece *)
          theline := succ(theline);
    */
  } else
    clearpiece(pie);
}


/* end module book.getpiece version = 7.52; {of delmod.p 2000 Jul 30} */

/* ************************************************************************ */
/* end module package.getpiece version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brorgkey */
Static Void brorgkey(thefile, theline, org)
_TEXT *thefile;
long *theline;
orgkey *org;
{
  /* read organism key */
  /*bbb*/
  brheader(thefile, theline, &org->hea);
  getline(&org->mapunit);
  brline(thefile, theline, &org->mapunit);
}


/* end module book.brorgkey version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.brchrkey */
Static Void brchrkey(thefile, theline, chr)
_TEXT *thefile;
long *theline;
chrkey *chr;
{
  /* read chromosome key */
  /*bbb*/
  brheader(thefile, theline, &chr->hea);
  brreanum(thefile, theline, &chr->mapbeg);
  brreanum(thefile, theline, &chr->mapend);
}


/* end module book.brchrkey version = 7.52; {of delmod.p 2000 Jul 30} */

/**************************************************************************/
/**************************************************************************/
/**************************************************************************/

/* begin module package.bwrite */
/****************************************************************************/
/* this is a package of procedures for writing books,
   by gary stormo,  aug 17, 1982 */

/* begin module book.bwbasics */

Static Void bwstartline(book)
_TEXT *book;
{
  /* start a line of output to the book */
  fprintf(book->f, "* ");
}


Static Void bwline(book, l)
_TEXT *book;
line *l;
{
  /* write a line to the book */
  long i, FORLIM;

  if (l == NULL)
    return;
  bwstartline(book);
  if (l->length != 0) {
    FORLIM = l->length;
    for (i = 0; i < FORLIM; i++)
      putc(l->letters[i], book->f);
  }
  putc('\n', book->f);
}


Static Void bwtext(book, lines)
_TEXT *book;
line *lines;
{
  /* write a set of lines to the book */
  line *l = lines;

  while (l != NULL) {
    bwline(book, l);
    l = l->next;
  }
}


Static Void bwnote(book, note)
_TEXT *book;
line *note;
{
  /* writes the notes pointed to by 'note' to 'book' */
  if (note == NULL)
    return;
  fprintf(book->f, "note\n");
  bwtext(book, note);
  fprintf(book->f, "note\n");
}


Static Void bwnumber(book, num)
_TEXT *book;
long num;
{
  /* write a number to the book */
  bwstartline(book);
  fprintf(book->f, "%ld\n", num);
      /* pascal will expand the field as far as needed */
}


Static Void bwreanum(book, reanum)
_TEXT *book;
double reanum;
{
  /* write a real number to the book */
  bwstartline(book);
  fprintf(book->f, "%1.2f\n", reanum);   /* pascal will expand the field */
}


Static Void bwstate(book, sta)
_TEXT *book;
state sta;
{
  /* write a state to the book */
  bwstartline(book);
  switch (sta) {

  case on:
    fprintf(book->f, "on\n");
    break;

  case off:
    fprintf(book->f, "off\n");
    break;
  }
}


Static Void bwname(book, nam)
_TEXT *book;
name nam;
{
  /* write a name to the book */
  long i;

  bwstartline(book);
  for (i = 0; i < nam.length; i++)
    putc(nam.letters[i], book->f);
  putc('\n', book->f);
}


Static Void bwdirect(book, direct)
_TEXT *book;
direction direct;
{
  /* write a direction to the book */
  bwstartline(book);
  switch (direct) {

  case plus:
    fprintf(book->f, "+\n");
    break;

  case minus:
    fprintf(book->f, "-\n");
    break;
  }
}


Static Void bwconfig(book, config)
_TEXT *book;
configuration config;
{
  /* write a configuration to the book */
  bwstartline(book);
  switch (config) {

  case linear:
    fprintf(book->f, "linear\n");
    break;

  case circular:
    fprintf(book->f, "circular\n");
    break;
  }
}


Static Void bwheader(book, hea)
_TEXT *book;
header hea;
{
  /* write a key header to the book */
  bwname(book, hea.keynam);
  bwline(book, hea.fulnam);
  bwnote(book, hea.note);
}


Static Void bworgkey(book, org)
_TEXT *book;
orgkey org;
{
  /* write the organism key */
  bwheader(book, org.hea);
  bwline(book, org.mapunit);
}


Static Void bwchrkey(book, chr)
_TEXT *book;
chrkey chr;
{
  /* write the chromosome key */
  bwheader(book, chr.hea);
  bwreanum(book, chr.mapbeg);
  bwreanum(book, chr.mapend);
}


/* end module book.bwbasics version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.bworg */
Static Void bworg(thefile, org, chropen, orgopen)
_TEXT *thefile;
orgkey org;
boolean *chropen, *orgopen;
{
  /* this writes the organism key 'org' to 'thefile', and returns 'orgopen'
     as true.  if there is already a chromosome or organism open they
     are closed. */
  if (*chropen) {
    fprintf(thefile->f, "chromosome\n");
    *chropen = false;
  }
  if (*orgopen)
    fprintf(thefile->f, "organism\n");
  fprintf(thefile->f, "organism\n");
  bworgkey(&book, org);
  *orgopen = true;
}


/* end module book.bworg version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.bwchr */
Static Void bwchr(thefile, chr, chropen)
_TEXT *thefile;
chrkey chr;
boolean *chropen;
{
  /* write the chromosome key 'chr' to 'thefile' and return chropen as
     true.  if a chromosome is already open it is closed. */
  if (*chropen)
    fprintf(thefile->f, "chromosome\n");
  fprintf(thefile->f, "chromosome\n");
  bwchrkey(&book, chr);
  *chropen = true;
}


/* end module book.bwchr version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.bwdna */
Static Void bwdna(thefile, d)
_TEXT *thefile;
dnastring *d;
{
  /* write the dna pointed to by 'd' to 'thefile' */
  long i;   /* index to the sequence */
  long l;   /* index to the number of bases on the line */
  boolean newline = true;   /* true when a new line should be started */
  long FORLIM;

  fprintf(thefile->f, "dna\n");
  while (d != NULL) {
    FORLIM = d->length;
    for (i = 1; i <= FORLIM; i++) {
      if (newline) {
	bwstartline(thefile);
	l = 0;
	newline = false;
      }
      fputc(basetochar((base)P_getbits_UB(d->part, i - 1, 1, 3)), thefile->f);
      l++;
      if (l % 60 == 0 || i == d->length && d->next == NULL) {
	    /* end of line */
	      putc('\n', thefile->f);
	newline = true;
      }
/* p2c: delila.p, line 1558:
 * Note: Using % for possibly-negative arguments [317] */
      /* last base */
    }
    d = d->next;
  }
  if (!newline)   /* last base */
    putc('\n', thefile->f);
  fprintf(thefile->f, "dna\n");
}


/* end module book.bwdna version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.bwpie */
Static Void bwpie(thefile, pie)
_TEXT *thefile;
piece *pie;
{
  /* writes the information pointed to by 'pie' to 'thefile' */
  fprintf(thefile->f, "piece\n");
  bwheader(thefile, pie->key.hea);

  bwstartline(thefile);
  fprintf(thefile->f, "%1.2f\n", pie->key.mapbeg);

  bwstartline(thefile);
  if (pie->key.coocon == circular)
    fprintf(thefile->f, "circular\n");
  else
    fprintf(thefile->f, "linear\n");

  bwstartline(thefile);
  if (pie->key.coodir == plus)
    fprintf(thefile->f, "+\n");
  else
    fprintf(thefile->f, "-\n");

  bwstartline(thefile);
  fprintf(thefile->f, "%ld\n", pie->key.coobeg);

  bwstartline(thefile);
  fprintf(thefile->f, "%ld\n", pie->key.cooend);

  bwstartline(thefile);
  if (pie->key.piecon == circular)
    fprintf(thefile->f, "circular\n");
  else
    fprintf(thefile->f, "linear\n");

  bwstartline(thefile);
  if (pie->key.piedir == plus)
    fprintf(thefile->f, "+\n");
  else
    fprintf(thefile->f, "-\n");

  bwstartline(thefile);
  fprintf(thefile->f, "%ld\n", pie->key.piebeg);

  bwstartline(thefile);
  fprintf(thefile->f, "%ld\n", pie->key.pieend);
  bwdna(thefile, pie->dna);
  fprintf(thefile->f, "piece\n");
}


/* end module book.bwpie version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.bwref */
Static Void bwref(book, ref)
_TEXT *book;
reference ref;
{
  /* write a key reference to the book */
  bwname(book, ref.pienam);
  bwreanum(book, ref.mapbeg);
  bwdirect(book, ref.refdir);
  bwnumber(book, ref.refbeg);
  bwnumber(book, ref.refend);
}


/* end module book.bwref version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.bwgen */
Static Void bwgen(thefile, gene)
_TEXT *thefile;
genkey gene;
{
  /* this proecdure writes to 'thefile' the information in 'gene',
     properly formatted; */
  fprintf(thefile->f, "gene\n");
  bwheader(thefile, gene.hea);
  bwref(thefile, gene.ref);
  fprintf(thefile->f, "gene\n");
}


/* end module book.bwgen version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.bwtra */
Static Void bwtra(thefile, trans)
_TEXT *thefile;
trakey trans;
{
  /* this proecdure writes to 'thefile' the information in 'trans',
     properly formatted; */
  fprintf(thefile->f, "transcript\n");
  bwheader(thefile, trans.hea);
  bwref(thefile, trans.ref);
  fprintf(thefile->f, "transcript\n");
}


/* end module book.bwtra version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.bwmar */
Static Void bwmar(thefile, mark)
_TEXT *thefile;
marker mark;
{
  /* this proecdure writes to 'thefile' the information in 'mark',
     properly formatted; */
  long i, FORLIM;

  fprintf(thefile->f, "marker\n");
  bwheader(thefile, mark.key.hea);
  bwref(thefile, mark.key.ref);
  bwstate(thefile, mark.key.sta);
  bwstartline(thefile);
  FORLIM = mark.key.phenotype->length;
  for (i = 0; i < FORLIM; i++)
    putc(mark.key.phenotype->letters[i], thefile->f);
  putc('\n', thefile->f);
  bwdna(thefile, mark.dna);
  fprintf(thefile->f, "marker\n");
}


/* end module book.bwmar version = 7.52; {of delmod.p 2000 Jul 30} */

/****************************************************************************/
/* end module package.bwrite version = 7.52; {of delmod.p 2000 Jul 30} */

/**************************************************************************/
/**************************************************************************/
/**************************************************************************/

/* begin module nwpietoint */
Static long nwpietoint(p, pie)
long p;
piece *pie;
{
  /* no wrap version of pietoint */
  /* p is a coordinate on the piece.
     we want to transform p into a number
     from 1 to n: an internal coordinate system for
     easy manipulation of piece coordinates.  If the coordinate
     is off the end, bring it to just before the end. */
  long i;   /* an intermediate value */
  piekey *WITH;

  WITH = &pie->key;
  switch (WITH->piedir) {

  case plus:
    i = p - WITH->piebeg + 1;
    break;

  case minus:
    i = WITH->piebeg - p + 1;
    break;
  }
  if (i > piecelength(pie))
    i = piecelength(pie) + 1;
  if (i < 0)
    i = 0;
  /*
writeln(output,'nwpietoint ---------------');
if piedir = minus
then writeln(output,'nwpietoint: pidir is minus')
else writeln(output,'nwpietoint: pidir is plus');
writeln(output,'nwpietoint: p: ',p:1);
writeln(output,'nwpietoint: pieend: ',pieend:1);
writeln(output,'nwpietoint: i: ',i:1);
*/
  return i;
}


/* end module nwpietoint version = 1.89; (@ of dbmutate.p 1999 April 26 */

/* note: 3 bars indicate breaks between major sections of code */
/**************************************************************************/
/* catalogue procedures ***************************************************/
/**************************************************************************/

Static Void tvrslibrary(future)
node future;
{
  /* check that the library is traversed properly, set nodeletter */
  step thisstep;

  memcpy(thisstep, traversalchart[(long)pastlibrary]
	 [(long)future], sizeof(step));
  if (!strncmp(thisstep, illegaltraversal, sizeof(step))) {
    printf(" program error:  illegal library traversal %12d to %12d\n",
	   (int)pastlibrary, (int)future);
    halt();
  }
  pastlibrary = future;
  nodeletter = nodechar[(long)future];
}


/**************************************************************************/

Static Void grabitem(cat, it)
catfile *cat;
item *it;
{
  /* grab an item from the cat */
  *it = GETFBUF(cat->f, item);
  if (!BUFEOF(cat->f))
    GET(cat->f, item);
}  /* grabitem */


Static Void crcatheader(cat, catnum, alp)
catfile *cat;
long catnum;
Char *alp;
{
  /* read the catalogue header (date of creation)
     from the catalogue file, cat */
  item it;   /* a catalogue item for unloading */
  long i;   /* index to date */

  /* the header of the catalogue resides in the first item */
  if (*cat->name != '\0') {
    if (cat->f != NULL)
      cat->f = freopen(cat->name, "rb", cat->f);
    else
      cat->f = fopen(cat->name, "rb");
  } else
    rewind(cat->f);
  if (cat->f == NULL)
    _EscIO2(FileNotFound, cat->name);
  RESETBUF(cat->f, item);
  if (BUFEOF(cat->f))
    return;
  /* else: objections to this case are made in checklibcat */
  grabitem(cat, &it);
  for (i = 0; i < datetimearraylength; i++)
    alp[i] = it.nam.letters[i];
  catline[catnum-1] = 2;
}  /* crcatheader */


Static Void nextitem(newitem)
item *newitem;
{
  /* this procedure finds the next item in the files,
     returns that item and the new current line and
     makes itemfound = true.  if itemfound is false after calling
     this routine it means that the last item was the end of last file.
        by gary stormo aug 28,1979
        modified by tom schneider 79 sep 7 */
  itemfound = false;
  switch (catnumber) {   /* ccc */

  case 1:
    if (!BUFEOF(cat1.f)) {
      grabitem(&cat1, newitem);
      itemfound = true;
    }
    break;

  case 2:
    if (!BUFEOF(cat2.f)) {
      grabitem(&cat2, newitem);
      itemfound = true;
    }
    break;

  case 3:
    if (!BUFEOF(cat3.f)) {
      grabitem(&cat3, newitem);
      itemfound = true;
    }
    break;
  }
  if (itemfound) {
    catline[catnumber-1]++;
    return;
  }
  switch (catnumber) {   /* ccc */

  case 1:
    catnumber = 2;
    if (*cat2.name != '\0') {
      if (cat2.f != NULL)
	cat2.f = freopen(cat2.name, "rb", cat2.f);
      else
	cat2.f = fopen(cat2.name, "rb");
    } else
      rewind(cat2.f);
    if (cat2.f == NULL)
      _EscIO2(FileNotFound, cat2.name);
    RESETBUF(cat2.f, item);
    if (!BUFEOF(cat2.f)) {
      grabitem(&cat2, newitem);   /* skip date */
      grabitem(&cat2, newitem);
      itemfound = true;
    }
    break;

  case 2:
    catnumber = 3;
    if (*cat3.name != '\0') {
      if (cat3.f != NULL)
	cat3.f = freopen(cat3.name, "rb", cat3.f);
      else
	cat3.f = fopen(cat3.name, "rb");
    } else
      rewind(cat3.f);
    if (cat3.f == NULL)
      _EscIO2(FileNotFound, cat3.name);
    RESETBUF(cat3.f, item);
    if (!BUFEOF(cat3.f)) {
      grabitem(&cat3, newitem);   /* skip date */
      grabitem(&cat3, newitem);
      itemfound = true;
    }
    break;

  case 3:
    /* blank case */
    break;
  }
  catline[catnumber-1] = 2;   /* 2 because first item was read */
  /* go to the next file */
}  /* nextitem */


/* Local variables for finditem: */
struct LOC_finditem {
  node newnode;
  name n;
  item *newitem;
  long *fi, numsearched;
} ;

/* Local variables for search: */
struct LOC_search {
  struct LOC_finditem *LINK;
  catfile *cat;
} ;

/* when the keyname is not found between the
                      beginning of the search and the nodeletter
                      of a higher structure - to reset and research */

Local Void readcat(LINK)
struct LOC_search *LINK;
{
  /* read a catalogue item */
  grabitem(LINK->cat, LINK->LINK->newitem);
  catline[catnumber-1]++;
  /*;if debugging then
writeln(debug,'readcat, catnumber=',catnumber:3,' catline='
        ,catline[catnumber]:4);*/
}

Local Void find(LINK)
struct LOC_search *LINK;
{
  /* find an item. if found set itemfound true */
  /*if debugging then writeln(debug,'find');*/
  readcat(LINK);
  if (LINK->LINK->newitem->letter != nodeletter)
    return;
  if (strncmp(LINK->LINK->newitem->nam.letters, LINK->LINK->n.letters,
	      sizeof(alpha)))
    return;
  if (debugging)
    fprintf(debug.f, "found %c %.*s\n",
	    LINK->LINK->newitem->letter, namelength,
	    LINK->LINK->newitem->nam.letters);
  itemfound = true;

  /* the file is the same as the catalogue */
  *LINK->LINK->fi = catnumber;

  switch (nodeletter) {

  case 'o':
    currento = catline[catnumber-1];
    break;

  case 'c':
    currentc = catline[catnumber-1];
    break;

  case 'r':
    currentr = catline[catnumber-1];
    break;

  case 't':
  case 'm':
  case 'g':
  case 'p':
  case 'e':
    currentl = catline[catnumber-1];
    break;
  }
}  /* find */

Local Void searchbetween(start, stop, LINK)
long start, stop;
struct LOC_search *LINK;
{
  /* search the cat between start and stop */
  /* reset the cat */
  if (*LINK->cat->name != '\0') {
    if (LINK->cat->f != NULL)
      LINK->cat->f = freopen(LINK->cat->name, "rb", LINK->cat->f);
    else
      LINK->cat->f = fopen(LINK->cat->name, "rb");
  } else
    rewind(LINK->cat->f);
  if (LINK->cat->f == NULL)
    _EscIO2(FileNotFound, LINK->cat->name);
  RESETBUF(LINK->cat->f, item);
  catline[catnumber-1] = 1;
  readcat(LINK);   /* skip header of cat */

  /* get to start */
  while (catline[catnumber-1] < start)
    readcat(LINK);

  /* scan */
  while (!itemfound && catline[catnumber-1] < stop)
    find(LINK);
}

/* the number of catalogues searched
                           in this particular finditem call */

Local Void search(cat_, LINK)
catfile *cat_;
struct LOC_finditem *LINK;
{
  /* search one of the catfiles */
  struct LOC_search V;
  boolean stuck = false;

  V.LINK = LINK;
  V.cat = cat_;
  /* do a search for the item, first going down the file from the
     current spot, then, if it is not there (stuck) reset the file,
     skip to the currently specified structure and scan back to the
     spot we started from. */
  if (debugging)
    fprintf(debug.f, "search cat %d\n", catnumber);
  itemfound = false;
  tvrslibrary(LINK->newnode);
  while (((!itemfound) & (!BUFEOF(V.cat->f))) && !stuck) {
    /* search below current spot */
    switch (nodeletter) {

    case 'o':
    case 'r':
      find(&V);
      break;

    case 'c':
    case 'e':
      find(&V);
      if (LINK->newitem->letter == 'r' || LINK->newitem->letter == 'o')
	stuck = true;
      break;

    case 't':
    case 'm':
    case 'g':
    case 'p':
      find(&V);
      if (LINK->newitem->letter == 'c' || LINK->newitem->letter == 'r' ||
	  LINK->newitem->letter == 'o')
	stuck = true;
      break;
    }
  }

  if (itemfound)   /* reset and search above current spot */
    return;
  switch (nodeletter) {

  case 'c':
    searchbetween(currento, currentc, &V);
    break;

  case 'e':
    searchbetween(currentr, currentl, &V);
    break;

  case 't':
  case 'm':
  case 'g':
  case 'p':
    searchbetween(currentc, currentl, &V);
    break;

  case 'o':
  case 'r':
    while (LINK->numsearched <= numcatfil && !itemfound) {
      /* search for o"s and r"s in multiple files */
      LINK->numsearched++;
      catnumber = catnumber % numcatfil + 1;   /* circular bump */
      catline[catnumber-1] = 1;   /* start a reset of the cat */
      switch (catnumber) {   /* ccc */

      case 1:
	if (*cat1.name != '\0') {
	  if (cat1.f != NULL)
	    cat1.f = freopen(cat1.name, "rb", cat1.f);
	  else
	    cat1.f = fopen(cat1.name, "rb");
	} else
	  rewind(cat1.f);
	if (cat1.f == NULL)
	  _EscIO2(FileNotFound, cat1.name);
	RESETBUF(cat1.f, item);
	search(&cat1, LINK);
	break;

      case 2:
	if (*cat2.name != '\0') {
	  if (cat2.f != NULL)
	    cat2.f = freopen(cat2.name, "rb", cat2.f);
	  else
	    cat2.f = fopen(cat2.name, "rb");
	} else
	  rewind(cat2.f);
	if (cat2.f == NULL)
	  _EscIO2(FileNotFound, cat2.name);
	RESETBUF(cat2.f, item);
	search(&cat2, LINK);
	break;

      case 3:
	if (*cat3.name != '\0') {
	  if (cat3.f != NULL)
	    cat3.f = freopen(cat3.name, "rb", cat3.f);
	  else
	    cat3.f = fopen(cat3.name, "rb");
	} else
	  rewind(cat3.f);
	if (cat3.f == NULL)
	  _EscIO2(FileNotFound, cat3.name);
	RESETBUF(cat3.f, item);
	search(&cat3, LINK);
	break;
      }
    }
    break;
  }
}  /* search */


Static Void finditem(newnode_, n_, newitem_, fi_)
node newnode_;
name n_;
item *newitem_;
long *fi_;
{
  /* procedure to search the catalogue for the requested item,
     returns the file number (fi) and line number of the request in the library.
     by gary stormo,  aug 28, 1979
     modified by tom schneider 79 sep 5 */
  /* this version assumes that no organism or recognition has been
     split in two between two files */
  struct LOC_finditem V;

  V.newnode = newnode_;
  V.n = n_;
  V.newitem = newitem_;
  V.fi = fi_;
  V.numsearched = 1;
  switch (catnumber) {   /* ccc */

  case 1:
    search(&cat1, &V);
    break;

  case 2:
    search(&cat2, &V);
    break;

  case 3:
    search(&cat3, &V);
    break;
  }
}  /* finditem */


/**************************************************************************/
/* library functions ******************************************************/
/**************************************************************************/

/* low level functions */

/* begin module package.datetime */
/* ************************************************************************ */
/* begin module getdatetime */
Static Void getdatetime(adatetime)
Char *adatetime;
{
  /* Get the date and time into a single array from the system clock.
     adatetime contains the date:
         1980/06/09 18:49:11
           ye mo da ho mi se
(year, month, day, hour, minute, second)
This version works after translation of the pascal by p2c
to C and then compiling with gcc. */
  Char adate[11], atime[11];
  /*
     adate, atime: alfa; (* ie, packed array[1..10] of char; *)
This old method won't work, since the last digit gets cut off!
  */
  Char month[3];
  long index;   /* index for times */

  /*
              1
     12345678901
adate[13-DEC-1999]
atime[17:39:44.00]
  */

  VAXdate(adate);
  VAXtime(atime);

  /*
writeln(output,'br: adate[',adate,'] atime[',atime,']');
*/

  /* transfer the year */
  for (index = 1; index <= 4; index++)
    adatetime[index-1] = adate[index+6];
  adatetime[4] = '/';
  for (index = 4; index <= 6; index++)
    month[index-4] = adate[index-1];
  if (!strncmp(month, "JAN", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '1';
  } else if (!strncmp(month, "FEB", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '2';
  } else if (!strncmp(month, "MAR", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '3';
  } else if (!strncmp(month, "APR", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '4';
  } else if (!strncmp(month, "MAY", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '5';
  } else if (!strncmp(month, "JUN", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '6';
  } else if (!strncmp(month, "JUL", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '7';
  } else if (!strncmp(month, "AUG", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '8';
  } else if (!strncmp(month, "SEP", 3)) {
    adatetime[5] = '0';
    adatetime[6] = '9';
  } else if (!strncmp(month, "OCT", 3)) {
    adatetime[5] = '1';
    adatetime[6] = '0';
  } else if (!strncmp(month, "NOV", 3)) {
    adatetime[5] = '1';
    adatetime[6] = '1';
  } else if (!strncmp(month, "DEC", 3)) {
    adatetime[5] = '1';
    adatetime[6] = '2';
  }
  adatetime[7] = '/';
  for (index = 7; index <= 8; index++)
    adatetime[index+1] = adate[index-7];

  /* replace blanks with spaces in dates */
  if (adatetime[5] == ' ')
    adatetime[5] = '0';
  if (adatetime[8] == ' ')
    adatetime[8] = '0';

  adatetime[10] = ' ';
  for (index = 10; index <= 17; index++)
    adatetime[index+1] = atime[index-10];
  for (index = 19; index <= datetimearraylength + 1; index++)
    adatetime[index] = ' ';
}


/* end module getdatetime version = 'cdatemod.p 1.19 1999Dec13'; */

/* begin module readdatetime */
Static Void readdatetime(thefile, adatetime)
_TEXT *thefile;
Char *adatetime;
{
  /* read the date and time from the file */
  long index;   /* to the udatetime */
  /* the following is an unpacked date time array, to avoid reading
  into a packed array.  reading into a packed array is not transportable */
  Char udatetime[datetimearraylength];

  for (index = 0; index < datetimearraylength; index++) {
    udatetime[index] = getc(thefile->f);
    if (udatetime[index] == '\n')
      udatetime[index] = ' ';
  }
  memcpy(adatetime, udatetime, sizeof(datetimearray));
  if (adatetime[2] == '/' && adatetime[11] == ':')
    printf(" old datetime (only 2 year digits) read: %.*s\n",
	   datetimearraylength, adatetime);
/* p2c: delila.p, line 2039: Note:
 * Format for packed-array-of-char will work only if width < length [321] */

  /*
        if (adatetime[3]<>'/') or (adatetime[12]<>':') then begin
           writeln(output,' bad date time read: ',adatetime:1);
           halt
        end;
        for index:=18 to datetimearraylength do adatetime[index]:=' '
  */
}


/* end module readdatetime version = 'cdatemod.p 1.19 1999Dec13'; */

/* begin module writedatetime */
Static Void writedatetime(thefile, adatetime)
_TEXT *thefile;
Char *adatetime;
{
  /* expand the date and time out and print in the file */
  long index;   /* index of datetime */

  for (index = 0; index < datetimearraylength; index++)
    putc(adatetime[index], thefile->f);
}


/* end module writedatetime version = 'cdatemod.p 1.19 1999Dec13'; */

/* begin module timeseed */
Static Void addtoseed(seed, power, c_)
double *seed, *power;
Char c_;
{
  /* add the digit represented by c to the seed at the power position */
  long n;   /* the character represented by c */

  *power /= 10;
  /*
writeln(output,'addtoseed, c = ',c);
writeln(output,'addtoseed, ord(c) = ',ord(c));
*/
  switch (c_) {

  case ' ':
    printf("timeseed: error in datetime\n");
    halt();
    break;

  case '0':
    n = 0;
    break;

  case '1':
    n = 1;
    break;

  case '2':
    n = 2;
    break;

  case '3':
    n = 3;
    break;

  case '4':
    n = 4;
    break;

  case '5':
    n = 5;
    break;

  case '6':
    n = 6;
    break;

  case '7':
    n = 7;
    break;

  case '8':
    n = 8;
    break;

  case '9':
    n = 9;
    break;
  }
  /*writeln(output,'timeseed number is [',n:1,']'); (@ debug */
  *seed += *power * n;
}  /* addtoseed */


Static Void makeseed(adatetime, seed)
Char *adatetime;
double *seed;
{
  /* convert adatetime to a real number in seed, reversed order */
  double power = 1.0;   /* a digit of the seed such as 0.01 */

  *seed = 0.0;
  addtoseed(seed, &power, adatetime[18]);
  addtoseed(seed, &power, adatetime[17]);
  /* : */
  addtoseed(seed, &power, adatetime[15]);
  addtoseed(seed, &power, adatetime[14]);
  /* : */
  addtoseed(seed, &power, adatetime[12]);
  addtoseed(seed, &power, adatetime[11]);
  /*   */
  addtoseed(seed, &power, adatetime[9]);
  addtoseed(seed, &power, adatetime[8]);
  /* / */
  addtoseed(seed, &power, adatetime[6]);
  addtoseed(seed, &power, adatetime[5]);
  /* / */
  addtoseed(seed, &power, adatetime[3]);
  addtoseed(seed, &power, adatetime[2]);
}


Static Void orderseed(adatetime, seed)
Char *adatetime;
double *seed;
{
  /* convert adatetime to a real number in seed, normal order */
  double power = 1.0;   /* a digit of the seed such as 0.01 */

  *seed = 0.0;
  addtoseed(seed, &power, adatetime[2]);
  addtoseed(seed, &power, adatetime[3]);
  addtoseed(seed, &power, adatetime[5]);
  addtoseed(seed, &power, adatetime[6]);
  /* / */
  addtoseed(seed, &power, adatetime[8]);
  addtoseed(seed, &power, adatetime[9]);
  /* / */
  addtoseed(seed, &power, adatetime[11]);
  addtoseed(seed, &power, adatetime[12]);
  /*   */
  addtoseed(seed, &power, adatetime[14]);
  addtoseed(seed, &power, adatetime[15]);
  /* : */
  addtoseed(seed, &power, adatetime[17]);
  addtoseed(seed, &power, adatetime[18]);
}


Static Void timeseed(seed)
double *seed;
{
  /* read the computer date and time.  reverse the order of the digits
and put a decimal point in front.  this gives a fraction between
zero and one that varies quite quickly, and is always unique (if the
computer has sufficient accuracy).  it is to be used as a seed to
a random number generator. */
  datetimearray adatetime;   /* a date and time */

  getdatetime(adatetime);
  /*
writeln(output,'timeseed: adatetime: ',adatetime);
*/
  makeseed(adatetime, seed);
}  /* timeseed */


/* end module timeseed version = 'cdatemod.p 1.19 1999Dec13'; */

/* begin module limitdate */
Static Void limitdate(a_, b, c_, d, limitdatetime_)
Char a_, b, c_, d;
Char *limitdatetime_;
{
  /* test whether the current time is before the limit.
If it is later, halt the program */
  datetimearray limitdatetime, adatetime;   /* a date and time */
  double Dday;   /* the critical day */
  double now;   /* this very moment */

  memcpy(limitdatetime, limitdatetime_, sizeof(datetimearray));
  getdatetime(adatetime);
  orderseed(adatetime, &now);

  if (limitdatetime[0] != ' ' || limitdatetime[1] != ' ' ||
      limitdatetime[2] != ' ' || limitdatetime[3] != ' ')
    halt();

  limitdatetime[0] = a_;
  limitdatetime[1] = b;
  limitdatetime[2] = c_;
  limitdatetime[3] = d;

  orderseed(limitdatetime, &Dday);

  /*
     writeln(output,'now:  ',now:20:8);
     writeln(output,'Dday: ',Dday:20:8);
  */
  if (now > Dday) {
    /*
           writeln(output,'This program expired on ',limitdatetime);
leave no clues
    */
    halt();
  }
}


/* end module limitdate version = 'cdatemod.p 1.19 1999Dec13'; */

/* ************************************************************************ */
/* end module package.datetime version = 'cdatemod.p 1.19 1999Dec13'; */

/* ************************************************************************ */
/* ************************************************************************ */
/* ************************************************************************ */

/* begin module book.other */
/* other useful dna, line and name manipulating functions */
/* begin module book.name */
Static Void clearname(n)
name n;
{
  /* clear the name n */
  long i;   /* index to piece name */

  n.length = 0;
  for (i = 0; i < namelength; i++)
    n.letters[i] = ' ';
}


Static Void writename(f, n)
_TEXT *f;
name n;
{
  /* write the name n to file f */
  long i;   /* index to piece name */

  for (i = 0; i < n.length; i++)
    putc(n.letters[i], f->f);
}


Static Void copyname(a_, b)
name a_, *b;
{
  /* copy name a to name b */
  long i;   /* index to piece name */

  for (i = 0; i < a_.length; i++)
    b->letters[i] = a_.letters[i];
  b->length = a_.length;
}


Static boolean equalname(a_, b)
name a_, b;
{
  /* is name a equal to name b? */
  long i = 1;   /* index to piece name */
  boolean same = true;   /* temporary variable to hold the answer */

  /* what optimism!! */
  if (b.length != a_.length)
    return false;
  while (same && i <= a_.length) {
    same = (b.letters[i-1] == a_.letters[i-1]);
    i++;
/* p2c: delila.p: Note: Eliminated unused assignment statement [338] */
  }
  return same;
}


/* end module book.name version = 7.52; {of delmod.p 2000 Jul 30} */

Static Void emptydna(l)
dnastring **l;
{
  /* empty all of the dna in l onto the freedna list */
  while (*l != NULL)
    cleardna(l);
}


Static Void emptyline(l)
line **l;
{
  /* empty all of the line in l onto the freeline list */
  long count;   /* count of lines removed */

  while (*l != NULL)
    clearline(l);
}


Static Void copyline(fromline, toline)
line *fromline, **toline;
{
  /* copy a set of lines */
  line *f, *t_;   /* internal pointers */

  /* destroy previous to line */
  emptyline(toline);
  if (fromline == NULL)
    return;
  getline(toline);
  f = fromline;
  t_ = *toline;
  while (f != NULL) {
    memcpy(t_->letters, f->letters, (long)linelength);
    t_->length = f->length;
    f = f->next;
    if (f != NULL) {
      getline(&t_->next);
      t_ = t_->next;
    } else
      t_->next = NULL;
  }
}


Static Void copydna(fromdna, todna)
dnastring **fromdna, **todna;
{
  /* copy a set of dna */
  dnastring *aDNAptr, *memdna;

  /* destroy previous to dna */
  while (*todna != NULL)
    cleardna(todna);
  aDNAptr = *fromdna;
  if (aDNAptr == NULL)
    return;
  getdna(&memdna);
  *todna = memdna;
  while (aDNAptr != NULL) {
    memcpy(memdna->part, aDNAptr->part, sizeof(seq));
    memdna->length = aDNAptr->length;
    aDNAptr = aDNAptr->next;
    if (aDNAptr != NULL) {
      getdna(&memdna->next);
      memdna = memdna->next;
    } else
      memdna->next = NULL;
  }
}


Static Void copypiece(Apiece, Bpiece)
piece *Apiece, **Bpiece;
{
  /* copy the pice a to piece b */
  (*Bpiece)->key.hea.keynam = Apiece->key.hea.keynam;
  copyline(Apiece->key.hea.fulnam, &(*Bpiece)->key.hea.fulnam);
  copyline(Apiece->key.hea.note, &(*Bpiece)->key.hea.note);
  (*Bpiece)->key.mapbeg = Apiece->key.mapbeg;
  (*Bpiece)->key.coocon = Apiece->key.coocon;
  (*Bpiece)->key.coodir = Apiece->key.coodir;
  (*Bpiece)->key.coobeg = Apiece->key.coobeg;
  (*Bpiece)->key.cooend = Apiece->key.cooend;
  (*Bpiece)->key.piecon = Apiece->key.piecon;
  (*Bpiece)->key.piedir = Apiece->key.piedir;
  (*Bpiece)->key.piebeg = Apiece->key.piebeg;
  (*Bpiece)->key.pieend = Apiece->key.pieend;
  copydna(&Apiece->dna, &(*Bpiece)->dna);
}


Static boolean between(a_, b, c_)
long a_, b, c_;
{
  /* is b between a and c? */
  /* this is an inclusive between */
  return (a_ <= b && b <= c_ || c_ <= b && b <= a_);
}


Static boolean within(pie, p)
piece *pie;
long p;
{
  /* is p (external coordinates) within the piece pie? */
  /* note 1: if coocon is linear then piecon must be linear.
     note 2: does the piece not go over the coordinate boundaries?
     note 3: if coocon is circular and piecon is circular,
             then one has the entire piece, so we can ask if p is within
             the coordinate system.
  */
  boolean Result;
  piekey *WITH;

  WITH = &pie->key;
  switch (WITH->coocon) {

  case linear:   /* note 1 */
    Result = between(WITH->piebeg, p, WITH->pieend);
    break;

  case circular:
    switch (WITH->piecon) {

    case linear:
      switch (WITH->piedir) {

      case plus:
	if (WITH->pieend >= WITH->piebeg)   /* note 2 */
	  Result = between(WITH->piebeg, p, WITH->pieend);
	else
	  Result = between(WITH->piebeg, p, WITH->cooend) |
		   between(WITH->coobeg, p, WITH->pieend);
	break;

      case minus:
	if (WITH->pieend <= WITH->piebeg)   /* note 2 */
	  Result = between(WITH->piebeg, p, WITH->pieend);
	else
	  Result = between(WITH->piebeg, p, WITH->coobeg) |
		   between(WITH->cooend, p, WITH->pieend);
	break;
      }
      break;

    case circular:
      Result = between(WITH->coobeg, p, WITH->cooend);   /* note 3 */
      break;
    }
    break;
  }
  return Result;
}


Static boolean withininternal(pie, p)
piece *pie;
long p;
{
  /* Is the internal position p inside the piece pie? */
  return ((p >= 1) & (p <= piecelength(pie)));
}


/* end module book.other version = 7.52; {of delmod.p 2000 Jul 30} */

Static Void showdnasegment(f, d, spot)
_TEXT *f;
dnastring *d;
long spot;
{
  /* show the dna segment to file f (for debugging),
and mark the given spot by surrouding it with parenthesis */
  long j;   /* index to the segment */
  long FORLIM;

  FORLIM = d->length;
  for (j = 1; j <= FORLIM; j++) {
    if (j == spot)
      putc('(', f->f);
    if (((1L << P_getbits_UB(d->part, j - 1, 1, 3)) & ((1L << ((long)a)) |
	   (1L << ((long)c)) | (1L << ((long)g)) | (1L << ((long)t)))) != 0)
      fputc(basetochar((base)P_getbits_UB(d->part, j - 1, 1, 3)), f->f);
    else
      fprintf(f->f, "%d", (int)((base)P_getbits_UB(d->part, j - 1, 1, 3)));
    if (j == spot)
      putc(')', f->f);
  }
  putc(' ', f->f);
}


Static Void showsegments(f, d)
_TEXT *f;
dnastring *d;
{
  /* show all dna segments to file f (for debugging) */
  dnastring *i = d;   /* index to the segments */
  long n = 0;   /* count of the segments */

  while (i != NULL) {
    showdnasegment(f, i, (long)i->length);
    n++;
    fprintf(f->f, " segment %ld\n", n);
    i = i->next;
  }
  putc('\n', f->f);
}


/* begin module book.getbase */
Static base getbase(position, pie)
long position;
piece *pie;
{
  /* Get a base from the position (internal coordinates) of the
     piece.  Protection is made against positions outside the piece.
In the case of circles it would be convenient to wrap around when
requests are off the end.  So the routine will do a modular
wrap for positions outside the range 1 to the length.
This is a new feature as of 2000 March 22.
  */
  dnastring *workdna;   /* pointer to the dna part of pie */
  long p;   /* current count of bases into the workdna */
  long spot;   /* the last base of the dna part */
  long thelength;   /* the length of the piece */

  /*
writeln(output,'NEW getbase: position=',position:1,'^^^^^^^^^^^^^^^^^^^^');
*/
  /* handle cases of position out of range by circular wrapping */
  thelength = piecelength(pie);
  while (position < 1)
    position += thelength;
  while (position > thelength)
    position -= thelength;

  workdna = pie->dna;
  p = workdna->length;
  while (position > p) {
    /*
writeln(output,' workdna^.length=',workdna^.length:1);
*/
    workdna = workdna->next;
    if (workdna == NULL) {
      printf("error in function getbase!\n");
      halt();
    }
    p += workdna->length;
  }
  /*
writeln(output,'p=',p:1);
*/
  if (true) {
    spot = workdna->length - p + position;
    /*
writeln(output,'spot=',spot:1);
showdnasegment(output,workdna, spot);
*/
    if (spot <= 0) {
      printf("error in getbase, spot (= %ld) must be positive\n", spot);
      halt();
    }
    if (spot > workdna->length) {
      printf("error in getbase, spot (=%ld) must be less than length (=%d)\n",
	     spot, workdna->length);
      halt();
    }
    /*
writeln(output,'base = ', workdna^.part[spot]);
*/
    return ((base)P_getbits_UB(workdna->part, spot - 1, 1, 3));
  }
  printf("error in getbase: request off end of piece\n");
  halt();
}


/* end module book.getbase version = 7.52; {of delmod.p 2000 Jul 30} */

Static Void reduceposition(pie, p)
piece *pie;
long *p;
{
  /* reduce the position p into the piece pie */
  long size;   /* size of a circle */
  piekey *WITH;

  WITH = &pie->key;
  if (WITH->piecon == circular) {
    /* circular correction of p */
    size = WITH->cooend - WITH->coobeg + 1;
    while (*p < WITH->coobeg)
      *p += size;
    while (*p > WITH->cooend)
      *p -= size;
    return;
  }
  switch (WITH->piedir) {

  /* linear correction of p
                         brings p to the closest edge of pie */
  case plus:
    if (*p < WITH->piebeg)
      *p = WITH->piebeg;
    else
      *p = WITH->pieend;
    break;

  case minus:
    if (*p < WITH->piebeg)
      *p = WITH->pieend;
    else
      *p = WITH->piebeg;
    break;
  }
}


/*YYY*/

/* ************************************************************************ */
/* ************************************************************************ */
/* ************************************************************************ */

/* routines for unimplemented functions */

Static Void getmarker(l)
marker **l;
{
  if (freemarker != NULL) {
    *l = freemarker;
    freemarker = freemarker->key.next;
  } else
    *l = (marker *)Malloc(sizeof(marker));
  (*l)->key.next = NULL;
}


Static Void clearmarker(l)
marker **l;
{
  marker *lptr;

  if (*l == NULL)
    return;
  lptr = *l;
  *l = (*l)->key.next;
  lptr->key.next = freemarker;
  freemarker = lptr;
}


Static Void getsite(l)
sitestring **l;
{
  if (freesite != NULL) {
    *l = freesite;
    freesite = freesite->next;
  } else
    *l = (sitestring *)Malloc(sizeof(sitestring));
  (*l)->length = 0;
  (*l)->next = NULL;
}


Static Void clearsite(l)
sitestring **l;
{
  sitestring *lptr;

  if (*l == NULL)
    return;
  lptr = *l;
  *l = (*l)->next;
  lptr->next = freesite;
  freesite = lptr;
}


/* ************************************************************************ */
/* ************************************************************************ */
/* ************************************************************************ */

Static boolean copylibname(tofile, lib, libnumber)
_TEXT *tofile, *lib;
long libnumber;
{
  /* copy the library name to a file.
     true returned means that one line was copied */
  Char ch;   /* reading character */

  if (*lib->name != '\0') {
    if (lib->f != NULL)
      lib->f = freopen(lib->name, "r", lib->f);
    else
      lib->f = fopen(lib->name, "r");
  } else
    rewind(lib->f);
  if (lib->f == NULL)
    _EscIO2(FileNotFound, lib->name);
  RESETBUF(lib->f, Char);
  if (!BUFEOF(lib->f)) {
    fprintf(tofile->f, "%ld ", libnumber);
    while (!P_eoln(lib->f)) {
      ch = getc(lib->f);
      if (ch == '\n')
	ch = ' ';
      putc(ch, tofile->f);
    }
    fscanf(lib->f, "%*[^\n]");
    getc(lib->f);
    putc('\n', tofile->f);
    libline[libnumber-1] = 2;
    return true;
  } else
    return false;
}


Static Void checklib(thefile, chexpected, fi, li)
_TEXT *thefile;
Char chexpected;
long fi, li;
{
  /* check that the character found in the library was the one expected
     fi is the file number and li is the line number */
  /* the global firstch is the character found by reading in the library */
  /*
no longer valid as of 1999 April 29:
this routine must not be removed since it affects thefile. */
  /*
        readln(thefile,firstch);
This readln is now handled by brheader!
1999 April 29
  */
  firstch = P_peek(thefile->f);
  if (chexpected == firstch)
    return;
  /*
zzzbbb
no longer valid as of 1999 April 29:
        libline[fi]:=succ(libline[fi])
  */
  printf(" delila: library does not match the catalogue\n");
  printf(" library %ld line %ld character expected: %c character found: %c\n",
	 fi, li, chexpected, firstch);
  printf(" (the order of the libraries and catalogues is probably wrong,\n");
  printf("  or the file is not a library)\n");
  halt();
}


/* read library variables *************************************************/
/* these procedure read attributes from the library.  they are all
   prefixed by l to indicate this.  */

/*zzz many of these are now out of date (and not called) and should be removed.
However, they are tied to the marker gene and transcript stuff, which is
still hanging around.  Those should all be replaced by 'features', or maybe
gene and transcript by features and markers by changes. */

Static Void libskipstar(thefile)
_TEXT *thefile;
{
  /* skip start of line (or star = '*').  the first character read is
     the global firstch. */
  Char c_;   /* a character in the file */

  if (skipping) {
    firstch = getc(thefile->f);
    if (firstch == '\n')
      firstch = ' ';
    if (firstch != '*') {
      printf(" delila: the file lib%d is bad.\n", catnumber);
      printf(" either line %ld is missing an asterisk (*) on the attribute\n",
	     libline[catnumber-1]);
      printf(" or the file is not a delila data base.\n");
      printf("The library line is:\n");
      putchar(firstch);
      while (!P_eoln(thefile->f)) {
	c_ = getc(thefile->f);
	if (c_ == '\n')
	  c_ = ' ';
	putchar(c_);
      }
      putchar('\n');
      halt();
    }
  } else
    skipping = true;
  blank = getc(thefile->f);   /* skip the blank */
  if (blank == '\n') {
    /* turn skipping back on for next time */
    blank = ' ';
  }
}


Static Void lrreanum(thefile, reanum)
_TEXT *thefile;
double *reanum;
{
  /* read a real number from the file */
  libskipstar(thefile);
  fscanf(thefile->f, "%lg%*[^\n]", reanum);
  getc(thefile->f);
}


Static Void lrnumber(thefile, num)
_TEXT *thefile;
long *num;
{
  /* read a number from the file */
  libskipstar(thefile);
  fscanf(thefile->f, "%ld%*[^\n]", num);
  getc(thefile->f);
}


/* unpacked alpha for reading from files: */
typedef Char ualpha[namelength];


Static Void lrname(thefile, nam)
_TEXT *thefile;
name *nam;
{
  /* read a name from the file */
  long i;   /* index to name */
  ualpha unamlets;   /* unpacked name */

  libskipstar(thefile);
  nam->length = 0;
  while (!P_eoln(thefile->f) && nam->length < namelength) {
    nam->length++;
    unamlets[nam->length - 1] = getc(thefile->f);
    if (unamlets[nam->length - 1] == '\n')
      unamlets[nam->length - 1] = ' ';
  }
  memcpy(nam->letters, unamlets, sizeof(alpha));
  if (nam->length < namelength) {   /* fill rest of name with blanks */
    for (i = nam->length; i < namelength; i++)
      nam->letters[i] = ' ';
  }
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
}


Static Void lrline(thefile, l)
_TEXT *thefile;
line **l;
{
  /* read a line from the file */
  long i = 0;
  long j;
  Char acharacter;
  long FORLIM;

  libskipstar(thefile);
  while (!P_eoln(thefile->f)) {
    i++;
    acharacter = getc(thefile->f);
    if (acharacter == '\n')
      acharacter = ' ';
    (*l)->letters[i-1] = acharacter;
  }
  if (i < (*l)->length) {
    FORLIM = (*l)->length;
    for (j = i; j < FORLIM; j++)
      (*l)->letters[j] = ' ';
  }
  (*l)->length = i;
  (*l)->next = NULL;
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
}


Static Void lrdirect(thefile, direct)
_TEXT *thefile;
direction *direct;
{
  /* read a direction */
  libskipstar(thefile);
  fscanf(thefile->f, "%c%*[^\n]", &ch);
  getc(thefile->f);
  if (ch == '\n')
    ch = ' ';
  if (ch == '+')
    *direct = plus;
  else
    *direct = minus;
}


Static Void lrconfig(thefile, config)
_TEXT *thefile;
configuration *config;
{
  /* read a configuration */
  libskipstar(thefile);
  fscanf(thefile->f, "%c%*[^\n]", &ch);
  getc(thefile->f);
  if (ch == '\n')
    ch = ' ';
  if (ch == 'l')
    *config = linear;
  else
    *config = circular;
}


Static Void lrstate(thefile, sta)
_TEXT *thefile;
state *sta;
{
  /* read a state */
  libskipstar(thefile);
  ch = getc(thefile->f);
  if (ch == '\n')
    ch = ' ';
  if (ch != 'o') {
    printf("delila: in procedure lrstate: state does not start with o\n");
    halt();
  }
  fscanf(thefile->f, "%c%*[^\n]", &ch);
  getc(thefile->f);
  if (ch == '\n')
    ch = ' ';
  if (ch == 'n')
    *sta = on;
  else
    *sta = off;
}


/* read partial keys of library *******************************************/

Static Void lrlibheader(lib, libnum, alp)
_TEXT *lib;
long libnum;
Char *alp;
{
  /* read the library header (date of creation) from the library file, lib */
  /* the header of the library resides in the first line */
  if (*lib->name != '\0') {
    if (lib->f != NULL)
      lib->f = freopen(lib->name, "r", lib->f);
    else
      lib->f = fopen(lib->name, "r");
  } else
    rewind(lib->f);
  if (lib->f == NULL)
    _EscIO2(FileNotFound, lib->name);
  RESETBUF(lib->f, Char);
  if (BUFEOF(lib->f))
    return;
  libskipstar(lib);
  readdatetime(lib, alp);
  fscanf(lib->f, "%*[^\n]");
  getc(lib->f);
  libline[libnum-1] = 2;
}


/* Local variables for lrheader: */
struct LOC_lrheader {
  _TEXT *thefile;
  long lines;
} ;

Local Void lrnote(note, LINK)
line **note;
struct LOC_lrheader *LINK;
{
  /* read note key */
  line *newnote;   /* the new note */
  line *previousnote;   /* the last line of the notes */

  firstch = getc(LINK->thefile->f);
  if (firstch == '\n')
    firstch = ' ';
  if (firstch != 'n') {  /* enter note */
    skipping = false;
    return;
  }
  fscanf(LINK->thefile->f, "%*[^\n]");
  getc(LINK->thefile->f);
  LINK->lines++;
  firstch = getc(LINK->thefile->f);
  if (firstch == '\n')
    firstch = ' ';
  if (firstch != 'n') {  /* abort null note (n/n) */
    getline(note);
    newnote = *note;
    while (firstch != 'n') {  /* wait until end of note */
      skipping = false;
      lrline(LINK->thefile, &newnote);
      LINK->lines++;
      firstch = getc(LINK->thefile->f);
      if (firstch == '\n')
	firstch = ' ';
      previousnote = newnote;
      /* get next note */
      getline(&newnote->next);
      newnote = newnote->next;
    }
    /* last note was not used, so: */
    clearline(&newnote);
    previousnote->next = NULL;
    fscanf(LINK->thefile->f, "%*[^\n]");
    getc(LINK->thefile->f);
    LINK->lines++;
    return;
  }
  fscanf(LINK->thefile->f, "%*[^\n]");
  getc(LINK->thefile->f);
  LINK->lines++;
}


Static Void lrheader(thefile_, fi, hea)
_TEXT *thefile_;
long fi;
header *hea;
{
  /* read the header of a key. */
  struct LOC_lrheader V;

  V.thefile = thefile_;
  clearheader(hea);
  /* read key name */
  lrname(V.thefile, &hea->keynam);

  /* read full name */
  getline(&hea->fulnam);
  lrline(V.thefile, &hea->fulnam);
  V.lines = 2;

  /* read note key */
  lrnote(&hea->note, &V);
  libline[fi-1] += V.lines;
}


Static Void lrreference(thefile, fi, ref)
_TEXT *thefile;
long fi;
reference *ref;
{
  lrname(thefile, &ref->pienam);
  lrreanum(thefile, &ref->mapbeg);
  lrdirect(thefile, &ref->refdir);
  lrnumber(thefile, &ref->refbeg);
  lrnumber(thefile, &ref->refend);
  libline[fi-1] += 5;
}


/* library file location routine ***************************************/
Static Void libgetto(thefile, fi, li)
_TEXT *thefile;
long fi, li;
{
  /* move thefile to the location requested: file fi and line li */
  long currentline;
  datetimearray dummyname;

  /*
writeln(output,'libgetto START');
*/
  /*zzzbbb*/
  /* get to the line */
  /*;if debugging then
writeln(debug,'getfileprelibline[',fi:3,']=',libline[fi]:4);*/
  currentline = libline[fi-1];
  if (currentline > li) {
    /* reset and skip library header */
    lrlibheader(thefile, fi, dummyname);
    currentline = libline[fi-1];
  }
  while (currentline < li) {
    fscanf(thefile->f, "%*[^\n]");
    getc(thefile->f);
    currentline++;
  }
  /*
writeln(output,'libgetto: thefile^ = ',thefile^);
*/
  /*zzzbbb*/
  libline[fi-1] = currentline;
  /*if debugging then
;writeln(debug,'getfilepostlibline[',fi:3,']=',libline[fi]:4);*/
}  /* libgetto */


/* top level librarian functions ******************************************/

/* begin module delila.marksautomate */
Static Void marksautomate(markspots)
_TEXT *markspots;
{
  /* define the components necessary for markspots */
  fprintf(markspots->f,
	  "* marksdelila: define markings for the lister program\n");
  fprintf(markspots->f, "* written by Delila version %4.2f\n", version);
  fprintf(markspots->f,
	  "* The standard marks.arrow must be used prior to this file.\n\n");
  fprintf(markspots->f, "u\n");
  fprintf(markspots->f, "%% This message will appear if you forgot your\n");
  fprintf(markspots->f, "%% marks.arrow definition:\n");
  fprintf(markspots->f, "You_need_a_marks.arrow_definition\n\n");
  fprintf(markspots->f, "/setmarkspotarrow{\n");
  fprintf(markspots->f, "/bodycolor {black} def\n");
  fprintf(markspots->f, "/strokecolor {black} def\n");
  fprintf(markspots->f, "/BodyThick     0.30 fs def\n");
  fprintf(markspots->f, "/HeadWidth     0.90 fs def\n");
  fprintf(markspots->f, "/HeadLength    1.50 fs def\n");
  fprintf(markspots->f, "} def\n");
  fprintf(markspots->f, "setmarkspotarrow\n\n");
  fprintf(markspots->f,
	  "/change   {%% tailx taily headx heady shift change\n");
  fprintf(markspots->f, "%% the head of an arrow\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "setmarkspotarrow\n");
  fprintf(markspots->f, "fixedarrow\n");
  fprintf(markspots->f, "} def\n\n");
  fprintf(markspots->f,
	  "/changeworra{%% tailx taily headx heady shift changeworra\n");
  fprintf(markspots->f,
	  "%% the tail of an arrow is a 'worra' (spelling backards)\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "setmarkspotarrow\n");
  fprintf(markspots->f, "fixedworra\n");
  fprintf(markspots->f, "} def\n\n");

  /* no longer needed:
*/
  fprintf(markspots->f,
	  "/insertion{%% tailx taily headx heady shift insertion\n");
  fprintf(markspots->f, "%% an insertion is a green rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "/bodycolor {lightgreen} def\n");
  fprintf(markspots->f, "boundrectangle\n");
  fprintf(markspots->f, "} def\n\n");
  fprintf(markspots->f,
	  "/deletion {%% tailx taily headx heady shift deletion\n");
  fprintf(markspots->f, "%% a deletion is a red rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "/bodycolor {lightred} def\n");
  fprintf(markspots->f, "boundrectangle\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f,
	  "/fullinsertion{%% tailx taily headx heady shift insertion\n");
  fprintf(markspots->f, "%% an insertion is a green rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "{lightgreen} {black} fullbox\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f,
	  "/leftinsertion{%% tailx taily headx heady shift insertion\n");
  fprintf(markspots->f, "%% an insertion is a green rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "{lightgreen} {black} leftbox\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f,
	  "/midinsertion{%% tailx taily headx heady shift insertion\n");
  fprintf(markspots->f, "%% an insertion is a green rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "{lightgreen} {black} midbox\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f,
	  "/rightinsertion{%% tailx taily headx heady shift insertion\n");
  fprintf(markspots->f, "%% an insertion is a green rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "{lightgreen} {black} rightbox\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f,
	  "/fulldeletion {%% tailx taily headx heady shift deletion\n");
  fprintf(markspots->f, "%% a deletion is a red rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "{lightred} {black} fullbox\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f,
	  "/leftdeletion {%% tailx taily headx heady shift deletion\n");
  fprintf(markspots->f, "%% a deletion is a red rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "{lightred} {black} leftbox\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f,
	  "/middeletion {%% tailx taily headx heady shift deletion\n");
  fprintf(markspots->f, "%% a deletion is a red rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "{lightred} {black} midbox\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f,
	  "/rightdeletion {%% tailx taily headx heady shift deletion\n");
  fprintf(markspots->f, "%% a deletion is a red rectangle\n");
  fprintf(markspots->f, "pop\n");
  fprintf(markspots->f, "{lightred} {black} rightbox\n");
  fprintf(markspots->f, "} def\n\n");

  fprintf(markspots->f, "!\n\n");
}


/* Local variables for initlibrarian: */
struct LOC_initlibrarian {
  long libcount;   /* the number of libraries in use */
} ;

Local Void checklibcat(lib, libnum, cat, catnum, LINK)
_TEXT *lib;
long libnum;
catfile *cat;
long catnum;
struct LOC_initlibrarian *LINK;
{
  /* check that a library corresponds to its catalogue */
  datetimearray libheader, catheader;   /* the dates of the two */

  if (!BUFEOF(lib->f)) {
    if (firstlibrary == 0)
      firstlibrary = libnum;
    catnumber = catnum;   /* keep the global up to date */
    lrlibheader(lib, libnum, libheader);
    crcatheader(cat, catnum, catheader);

    if (BUFEOF(cat->f)) {
      printf(" delila: missing catalogue %ld although library %ld is not empty\n",
	     catnum, libnum);
      halt();
    }

    if (strncmp(libheader, catheader, sizeof(datetimearray))) {
      printf(" delila: library %ld and catalogue %ld dates are not identical\n",
	     libnum, catnum);
      printf(" %.*s <> %.*s\n",
	     datetimearraylength, libheader, datetimearraylength, catheader);
      halt();
    }

    LINK->libcount++;
    return;
  }
  if (!BUFEOF(cat->f)) {
    printf(" delila: library %ld is empty, yet catalogue %ld is not empty\n",
	   libnum, catnum);
    halt();
    /* the library does not exist: does the cat? */
  }
}  /* checklibcat */


/* end module delila.marksautomate version = 1.89; (@ of dbmutate.p 1999 April 26 */

Static Void initlibrarian()
{
  /* reset library files and set up variables */
  struct LOC_initlibrarian V;
  long i;
  /*
apparently not used!
        indnum: numberedstructure; (* an index for def.num.str *)
  */
  node nodefrom, nodeto;

  /* announce ourselves */
  printf("delila %4.2f\n", version);
  printf("sequence segment size (dnamax) is %ld\n", (long)dnamax);

  /* get date and time */
  getdatetime(datetime);

  /* initialize library files */
  for (i = 0; i < numlibfil; i++)
    libline[i] = 1;
  /* lll */
  if (*lib1.name != '\0') {
    if (lib1.f != NULL)
      lib1.f = freopen(lib1.name, "r", lib1.f);
    else
      lib1.f = fopen(lib1.name, "r");
  } else
    rewind(lib1.f);
  if (lib1.f == NULL)
    _EscIO2(FileNotFound, lib1.name);
  RESETBUF(lib1.f, Char);
  if (*lib2.name != '\0') {
    if (lib2.f != NULL)
      lib2.f = freopen(lib2.name, "r", lib2.f);
    else
      lib2.f = fopen(lib2.name, "r");
  } else
    rewind(lib2.f);
  if (lib2.f == NULL)
    _EscIO2(FileNotFound, lib2.name);
  RESETBUF(lib2.f, Char);
  if (*lib3.name != '\0') {
    if (lib3.f != NULL)
      lib3.f = freopen(lib3.name, "r", lib3.f);
    else
      lib3.f = fopen(lib3.name, "r");
  } else
    rewind(lib3.f);
  if (lib3.f == NULL)
    _EscIO2(FileNotFound, lib3.name);
  RESETBUF(lib3.f, Char);

  /* initialize catalogue files */
  for (i = 0; i < numcatfil; i++)
    catline[i] = 1;
  catnumber = 1;   /* first cat to search */
  /* ccc */
  if (*cat1.name != '\0') {
    if (cat1.f != NULL)
      cat1.f = freopen(cat1.name, "rb", cat1.f);
    else
      cat1.f = fopen(cat1.name, "rb");
  } else
    rewind(cat1.f);
  if (cat1.f == NULL)
    _EscIO2(FileNotFound, cat1.name);
  RESETBUF(cat1.f, item);
  if (*cat2.name != '\0') {
    if (cat2.f != NULL)
      cat2.f = freopen(cat2.name, "rb", cat2.f);
    else
      cat2.f = fopen(cat2.name, "rb");
  } else
    rewind(cat2.f);
  if (cat2.f == NULL)
    _EscIO2(FileNotFound, cat2.name);
  RESETBUF(cat2.f, item);
  if (*cat3.name != '\0') {
    if (cat3.f != NULL)
      cat3.f = freopen(cat3.name, "rb", cat3.f);
    else
      cat3.f = fopen(cat3.name, "rb");
  } else
    rewind(cat3.f);
  if (cat3.f == NULL)
    _EscIO2(FileNotFound, cat3.name);
  RESETBUF(cat3.f, item);

  if (*inst.name != '\0') {
    if (inst.f != NULL)
      inst.f = freopen(inst.name, "r", inst.f);
    else
      inst.f = fopen(inst.name, "r");
  } else
    rewind(inst.f);
  if (inst.f == NULL)
    _EscIO2(FileNotFound, inst.name);
  RESETBUF(inst.f, Char);
  if (*listing.name != '\0') {
    if (listing.f != NULL)
      listing.f = freopen(listing.name, "w", listing.f);
    else
      listing.f = fopen(listing.name, "w");
  } else {
    if (listing.f != NULL)
      rewind(listing.f);
    else
      listing.f = tmpfile();
  }
  if (listing.f == NULL)
    _EscIO2(FileNotFound, listing.name);
  SETUPBUF(listing.f, Char);
  if (*book.name != '\0') {
    if (book.f != NULL)
      book.f = freopen(book.name, "w", book.f);
    else
      book.f = fopen(book.name, "w");
  } else {
    if (book.f != NULL)
      rewind(book.f);
    else
      book.f = tmpfile();
  }
  if (book.f == NULL)
    _EscIO2(FileNotFound, book.name);
  SETUPBUF(book.f, Char);
  if (debugging) {
    if (*debug.name != '\0') {
      if (debug.f != NULL)
	debug.f = freopen(debug.name, "w", debug.f);
      else
	debug.f = fopen(debug.name, "w");
    } else {
      if (debug.f != NULL)
	rewind(debug.f);
      else
	debug.f = tmpfile();
    }
    if (debug.f == NULL)
      _EscIO2(FileNotFound, debug.name);
    SETUPBUF(debug.f, Char);
  }

  /* note: this variable must be set before the checklib calls */
  /* skip both characters before an attribute in the library */
  skipping = true;

  /* are there instructions? */
  if (BUFEOF(inst.f)) {
    printf(" delila: no instructions\n");
    halt();
  }

  /* check that all libraries correspond to their catalogues */
  V.libcount = 0;   /* how many libraries are we talking to? */
  firstlibrary = 0;   /* we have not found the first library yet */
  checklibcat(&lib1, 1L, &cat1, 1L, &V);
  checklibcat(&lib2, 2L, &cat2, 2L, &V);
  checklibcat(&lib3, 3L, &cat3, 3L, &V);
  if (V.libcount == 0) {
    printf("delila: no libraries\n");
    halt();
  }
  printf("%ld librar", V.libcount);   /* and now for the tail... */
  if (V.libcount == 1)
    printf("y\n");
  else
    printf("ies\n");

  /* initialize free storage */
  freeline = NULL;
  freemarker = NULL;
  freedna = NULL;
  freesite = NULL;

  /* clear memory of library piece */
  libpie = (piece *)Malloc(sizeof(piece));
  libpie->key.hea.fulnam = NULL;
  libpie->key.hea.note = NULL;
  libpie->dna = NULL;
  getdna(&libpie->dna);

  /* set up traversal chart */
  /* define illegal traversals: */
  memcpy(illegaltraversal, "illegal   ", sizeof(step));
  /* fill traversal chart with illegal traversals: */
  for (nodefrom = libnode;
       (long)nodefrom <= (long)sitenode;
       nodefrom = (node)((long)nodefrom + 1)) {
    for (nodeto = libnode;
	 (long)nodeto <= (long)sitenode;
	 nodeto = (node)((long)nodeto + 1))
      memcpy(traversalchart[(long)nodefrom]
	     [(long)nodeto], illegaltraversal, sizeof(step));
  }
  /* refill the chart with all the legal traversals */
  /* lib */
  memcpy(traversalchart[(long)libnode]
	 [(long)orgnode], "o.        ", sizeof(step));
  memcpy(traversalchart[(long)libnode]
	 [(long)recnode], "r.        ", sizeof(step));
  /* org */
  memcpy(traversalchart[(long)orgnode]
	 [(long)libnode], "o.        ", sizeof(step));
  memcpy(traversalchart[(long)orgnode]
	 [(long)orgnode], "oo.       ", sizeof(step));
  memcpy(traversalchart[(long)orgnode]
	 [(long)chrnode], "c.        ", sizeof(step));
  memcpy(traversalchart[(long)orgnode]
	 [(long)recnode], "or.       ", sizeof(step));
  /* chr */
  memcpy(traversalchart[(long)chrnode]
	 [(long)libnode], "co.       ", sizeof(step));
  memcpy(traversalchart[(long)chrnode]
	 [(long)orgnode], "coo.      ", sizeof(step));
  memcpy(traversalchart[(long)chrnode]
	 [(long)chrnode], "cc.       ", sizeof(step));
  memcpy(traversalchart[(long)chrnode]
	 [(long)marnode], "m.        ", sizeof(step));
  memcpy(traversalchart[(long)chrnode]
	 [(long)tranode], "t.        ", sizeof(step));
  memcpy(traversalchart[(long)chrnode]
	 [(long)gennode], "g.        ", sizeof(step));
  memcpy(traversalchart[(long)chrnode]
	 [(long)pienode], "p.        ", sizeof(step));
  memcpy(traversalchart[(long)chrnode]
	 [(long)recnode], "cor.      ", sizeof(step));
  /* mar */
  memcpy(traversalchart[(long)marnode]
	 [(long)mardnanode], "d.        ", sizeof(step));
  /* mardna */
  memcpy(traversalchart[(long)mardnanode]
	 [(long)libnode], "dmco.     ", sizeof(step));
  memcpy(traversalchart[(long)mardnanode]
	 [(long)orgnode], "dmcoo.    ", sizeof(step));
  memcpy(traversalchart[(long)mardnanode]
	 [(long)chrnode], "dmcc.     ", sizeof(step));
  memcpy(traversalchart[(long)mardnanode]
	 [(long)marnode], "dmm.      ", sizeof(step));
  memcpy(traversalchart[(long)mardnanode]
	 [(long)tranode], "dmt.      ", sizeof(step));
  memcpy(traversalchart[(long)mardnanode]
	 [(long)gennode], "dmg.      ", sizeof(step));
  memcpy(traversalchart[(long)mardnanode]
	 [(long)pienode], "dmp.      ", sizeof(step));
  memcpy(traversalchart[(long)mardnanode]
	 [(long)recnode], "dmcor.    ", sizeof(step));
  /* tra */
  memcpy(traversalchart[(long)tranode]
	 [(long)libnode], "tco.      ", sizeof(step));
  memcpy(traversalchart[(long)tranode]
	 [(long)orgnode], "tcoo.     ", sizeof(step));
  memcpy(traversalchart[(long)tranode]
	 [(long)chrnode], "tcc.      ", sizeof(step));
  memcpy(traversalchart[(long)tranode]
	 [(long)marnode], "tm.       ", sizeof(step));
  memcpy(traversalchart[(long)tranode]
	 [(long)tranode], "tt.       ", sizeof(step));
  memcpy(traversalchart[(long)tranode]
	 [(long)gennode], "tg.       ", sizeof(step));
  memcpy(traversalchart[(long)tranode]
	 [(long)pienode], "tp.       ", sizeof(step));
  memcpy(traversalchart[(long)tranode]
	 [(long)recnode], "tcor.     ", sizeof(step));
  /* gen */
  memcpy(traversalchart[(long)gennode]
	 [(long)libnode], "gco.      ", sizeof(step));
  memcpy(traversalchart[(long)gennode]
	 [(long)orgnode], "gcoo.     ", sizeof(step));
  memcpy(traversalchart[(long)gennode]
	 [(long)chrnode], "gcc.      ", sizeof(step));
  memcpy(traversalchart[(long)gennode]
	 [(long)marnode], "gm.       ", sizeof(step));
  memcpy(traversalchart[(long)gennode]
	 [(long)tranode], "gt.       ", sizeof(step));
  memcpy(traversalchart[(long)gennode]
	 [(long)gennode], "gg.       ", sizeof(step));
  memcpy(traversalchart[(long)gennode]
	 [(long)pienode], "gp.       ", sizeof(step));
  memcpy(traversalchart[(long)gennode]
	 [(long)recnode], "gcor.     ", sizeof(step));
  /* pie */
  memcpy(traversalchart[(long)pienode]
	 [(long)piednanode], "d.        ", sizeof(step));
  /* piedna */
  memcpy(traversalchart[(long)piednanode]
	 [(long)libnode], "dpco.     ", sizeof(step));
  memcpy(traversalchart[(long)piednanode]
	 [(long)orgnode], "dpcoo.    ", sizeof(step));
  memcpy(traversalchart[(long)piednanode]
	 [(long)chrnode], "dpcc.     ", sizeof(step));
  memcpy(traversalchart[(long)piednanode]
	 [(long)marnode], "dpm.      ", sizeof(step));
  memcpy(traversalchart[(long)piednanode]
	 [(long)tranode], "dpt.      ", sizeof(step));
  memcpy(traversalchart[(long)piednanode]
	 [(long)gennode], "dpg.      ", sizeof(step));
  memcpy(traversalchart[(long)piednanode]
	 [(long)pienode], "dpp.      ", sizeof(step));
  memcpy(traversalchart[(long)piednanode]
	 [(long)recnode], "dpcor.    ", sizeof(step));
  /* rec */
  memcpy(traversalchart[(long)recnode]
	 [(long)orgnode], "r.        ", sizeof(step));
  memcpy(traversalchart[(long)recnode]
	 [(long)orgnode], "ro.       ", sizeof(step));
  memcpy(traversalchart[(long)recnode]
	 [(long)recnode], "rr.       ", sizeof(step));
  memcpy(traversalchart[(long)recnode]
	 [(long)enznode], "e.        ", sizeof(step));
  /* enz */
  memcpy(traversalchart[(long)enznode]
	 [(long)sitenode], "s.        ", sizeof(step));
  /* site */
  memcpy(traversalchart[(long)sitenode]
	 [(long)libnode], "ser.      ", sizeof(step));
  memcpy(traversalchart[(long)sitenode]
	 [(long)orgnode], "sero.     ", sizeof(step));
  memcpy(traversalchart[(long)sitenode]
	 [(long)recnode], "serr.     ", sizeof(step));
  memcpy(traversalchart[(long)sitenode]
	 [(long)enznode], "see.      ", sizeof(step));
  memcpy(traversalchart[(long)sitenode]
	 [(long)sitenode], "ss.       ", sizeof(step));

  /*experimental: allow piece directly since supposedly
accession numbers are unique (ha!)
zzz
        traversalchart[libnode,pienode]:='p.        ';
  */

  /* start library at library (top level) node */
  pastlibrary = libnode;
  pastbook = libnode;
  pastcheck = libnode;

  /* set up the characters that correspond to each node */
  nodechar[(long)libnode] = 'l';
  nodechar[(long)orgnode] = 'o';
  nodechar[(long)chrnode] = 'c';
  nodechar[(long)marnode] = 'm';
  nodechar[(long)mardnanode] = 'd';
  nodechar[(long)tranode] = 't';
  nodechar[(long)gennode] = 'g';
  nodechar[(long)pienode] = 'p';
  nodechar[(long)piednanode] = 'd';
  nodechar[(long)recnode] = 'r';
  nodechar[(long)enznode] = 'e';
  nodechar[(long)sitenode] = 's';
  nodeletter = nodechar[(long)libnode];

  /* for zeroing the coordinate system */
  zerobase = 0;
  zeroshift = 0;

  /* make sure that there is no previous name: */
  clearname(lastpiecename);

  withused = false;   /* control rewrite of marksdelila here */
  /*
old code - delete later -
     rewrite(marksdelila);
     marksautomate(marksdelila);
  */

  booksize = 0;   /* for comparing to maxbook */

}  /* initlibrarian */


/* Local variables for lrorgkey: */
struct LOC_lrorgkey {
  orgkey *org;
  item it;
  long fi;
} ;

Local Void rorgkey(thefile, LINK)
_TEXT *thefile;
struct LOC_lrorgkey *LINK;
{
  orgkey *WITH;

  WITH = LINK->org;
  libgetto(thefile, LINK->fi, LINK->it.line_);
  /*zzzbbb*/
  /*
writeln(output,'lrorgkey');
writeln(output,'thefile^ = ',thefile^);
writeln(output,'line = ',line:1);
writeln(output,'fi = ',fi:1);
*/
  checklib(thefile, nodeletter, LINK->fi, LINK->it.line_);
  /*
writeln(output,'thefile^ = ',thefile^);
writeln(output,'about to brorgkey:');
*/
  brorgkey(thefile, &libline[LINK->fi-1], LINK->org);
  /*
writeln(output,'lrorgkey DONE');
*/
}  /* rchrkey */


/* library reading procedures *********************************************/

Static Void lrorgkey(nam, org_)
name nam;
orgkey *org_;
{  /* lrogkey */
  /* read organism key */
  struct LOC_lrorgkey V;

  V.org = org_;
  /* a new chromosome means new pieces: */
  clearname(lastpiecename);
  finditem(orgnode, nam, &V.it, &V.fi);
  if (!itemfound)
    return;
  switch (V.fi) {   /* lll */

  case 1:
    rorgkey(&lib1, &V);
    break;

  case 2:
    rorgkey(&lib2, &V);
    break;

  case 3:
    rorgkey(&lib3, &V);
    break;
  }
}  /* lrorgkey */


/* Local variables for lrchrkey: */
struct LOC_lrchrkey {
  chrkey *chr;
  item it;
  long fi;
} ;

Local Void rchrkey(thefile, LINK)
_TEXT *thefile;
struct LOC_lrchrkey *LINK;
{  /* rorgkey */
  chrkey *WITH;

  WITH = LINK->chr;
  /*
writeln(output,'in rchrkey, about to libgetto');
*/
  libgetto(thefile, LINK->fi, LINK->it.line_);
  /*zzzbbb*/
  /*
writeln(output,'rCHRkey fi = ',fi:1);
writeln(output,'rCHRkey line = ',line:1);
writeln(output,'rCHRkey thefile^ = ',thefile^);
writeln(output,'rCHRkey about to checklib');
*/
  checklib(thefile, nodeletter, LINK->fi, LINK->it.line_);
  /*
writeln(output,'in rchrkey, about to brchrkey');
*/
  brchrkey(thefile, &libline[LINK->fi-1], LINK->chr);
  /*
writeln(output,'DONE rCHRkey fi = ',fi:1);
writeln(output,'DONE rCHRkey line = ',line:1);
writeln(output,'DONE rCHRkey libline[fi] = ',libline[fi]:1);
writeln(output,'DONE rCHRkey thefile^ = ',thefile^);
*/
}  /* rchrkey */


/* upgraded: */
Static Void lrchrkey(nam, chr_)
name nam;
chrkey *chr_;
{
  /* read chromosome key */
  struct LOC_lrchrkey V;

  V.chr = chr_;
  /* a new chromosome means new pieces: */
  clearname(lastpiecename);
  finditem(chrnode, nam, &V.it, &V.fi);
  if (!itemfound)
    return;
  switch (V.fi) {   /* lll */

  case 1:
    rchrkey(&lib1, &V);
    break;

  case 2:
    rchrkey(&lib2, &V);
    break;

  case 3:
    rchrkey(&lib3, &V);
    break;
  }
}  /* lrchrkey */


/* Local variables for lrtrakey: */
struct LOC_lrtrakey {
  trakey *tra;
  item it;
  long fi;
} ;

Local Void rtrakey(thefile, LINK)
_TEXT *thefile;
struct LOC_lrtrakey *LINK;
{  /* lrtrakey */
  trakey *WITH;

  WITH = LINK->tra;
  libgetto(thefile, LINK->fi, LINK->it.line_);
  checklib(thefile, nodeletter, LINK->fi, LINK->it.line_);
  lrheader(thefile, LINK->fi, &WITH->hea);
  lrreference(thefile, LINK->fi, &WITH->ref);
}  /* rtrakey */


/* not implemented
procedure lrmarker(nam: name; var markers: markerptr);
(* read a marker, string it into the markers linked list *)
var   it: item;
      fi: integer;
procedure rmarker(var thefile: text);
procedure lrmrky(nam: name; var mar: markey);
begin (* lrmrky *)
      with mar,it do begin
         checklib(thefile,nodeletter,fi,line);
         clearline(phenotype);
         getline(phenotype);
         lrheader(thefile,fi,hea);
         lrreference(thefile,fi,ref);
         lrstate(thefile,sta);
         lrline (thefile,phenotype);
         libline[fi]:=libline[fi]+2
      end
end; (* lrmrky *)
procedure lrmardna(var dna: dnaptr);
(* read marker dna *)
begin (* lrmardna *)
      tvrslibrary(mardnanode);
      dna:=nil;
      (* simple read of all the dna *)
      (* to write this code, refer to lrpiedna, but simplify it
         since the whole dna is read, and there is no complementing *)
      (* dummy *)
end; (* lrmardna *)
begin (* rmarker *)
      libgetto(thefile,fi, it.line);
      (* the linked list of markers should be scanned to find the
         last marker.  the new marker should then be inserted end *)
      (* alternatively, the new marker should be placed in the marker
         list in its proper position with respect to the coordinate system *)
      with markers^ do begin
         lrmrky(nam,key);
         lrmardna(dna)
      end
end; (* rmarker *)
begin (* lrmarker *)
      finditem(marnode,nam,it,fi);
      if itemfound then case fi of (* lll *)
         1: rmarker(lib1);
         2: rmarker(lib2);
         3: rmarker(lib3);
      end
end; (* lrmarker *)
*/

Static Void lrtrakey(nam, tra_)
name nam;
trakey *tra_;
{
  /* read transcript key */
  struct LOC_lrtrakey V;

  V.tra = tra_;
  finditem(tranode, nam, &V.it, &V.fi);
  if (!itemfound)
    return;
  switch (V.fi) {   /* lll */

  case 1:
    rtrakey(&lib1, &V);
    break;

  case 2:
    rtrakey(&lib2, &V);
    break;

  case 3:
    rtrakey(&lib3, &V);
    break;
  }
}  /* lrtrakey */


/* Local variables for lrgenkey: */
struct LOC_lrgenkey {
  genkey *gen;
  item it;
  long filenumber;
} ;

Local Void rgenkey(thefile, LINK)
_TEXT *thefile;
struct LOC_lrgenkey *LINK;
{
  genkey *WITH;

  WITH = LINK->gen;
  libgetto(thefile, LINK->filenumber, LINK->it.line_);
  checklib(thefile, nodeletter, LINK->filenumber, LINK->it.line_);
  /* to match the new getto rules, readln the file here: */
  fscanf(thefile->f, "%*[^\n]");
  getc(thefile->f);
  libline[LINK->filenumber-1]++;
  lrheader(thefile, LINK->filenumber, &WITH->hea);
  lrreference(thefile, LINK->filenumber, &WITH->ref);
}  /* rgenkey */


Static Void lrgenkey(nam, gen_)
name nam;
genkey *gen_;
{
  /* read gene key */
  struct LOC_lrgenkey V;

  V.gen = gen_;
  finditem(gennode, nam, &V.it, &V.filenumber);
  if (!itemfound)
    return;
  switch (V.filenumber) {   /* lll */

  case 1:
    rgenkey(&lib1, &V);
    break;

  case 2:
    rgenkey(&lib2, &V);
    break;

  case 3:
    rgenkey(&lib3, &V);
    break;
  }
}  /* lrgenkey */


/* Local variables for lrpiece: */
struct LOC_lrpiece {
  name nam;
  piece **libpie;
  item it;
  long filenumber;   /* the file to read */
} ;

Local Void rpiece(thefile, LINK)
_TEXT *thefile;
struct LOC_lrpiece *LINK;
{
  _TEXT TEMP;

  libgetto(thefile, LINK->filenumber, LINK->it.line_);
  /* use standard book reading routines: */
  /*
writeln(output,'lrpiece: line is ',it.line:1);
*/
  tvrslibrary(piednanode);   /* record that we traversed the tree */
  printf("Request for: ");
  TEMP.f = stdout;
  *TEMP.name = '\0';
  writename(&TEMP, LINK->nam);
  if (equalname(LINK->nam, lastpiecename) && lastpiecename.length > 0) {
    printf(" - same name as last time, keeping the same piece\n");
    return;
  }
  printf(" - reading in the piece\n");
  brpiece(thefile, &libline[LINK->filenumber-1], LINK->libpie);
  copyname((*LINK->libpie)->key.hea.keynam, &lastpiecename);
}  /* rpiece */


Static Void lrpiece(nam_, libpie_)
name nam_;
piece **libpie_;
{
  /* read a piece */
  struct LOC_lrpiece V;

  V.nam = nam_;
  V.libpie = libpie_;
  finditem(pienode, V.nam, &V.it, &V.filenumber);
  if (!itemfound)
    return;
  switch (V.filenumber) {   /* lll */

  case 1:
    rpiece(&lib1, &V);
    break;

  case 2:
    rpiece(&lib2, &V);
    break;

  case 3:
    rpiece(&lib3, &V);
    break;
  }
}  /* lrpiece */


/*not implemented
procedure lrreckey(nam: name; var rec: reckey);
(* read rececognition key *)
var   it: item;
      fi: integer;
procedure rreckey(var thefile: text);
begin (* rreckey *)
      with rec,it do begin
         libgetto(thefile,fi,line);
         checklib(thefile,nodeletter,fi,line);
         lrheader(thefile,fi,hea);
      end
end; (* rreckey *)
begin (* lrreckey *)
      finditem(recnode,nam,it,fi);
      if itemfound then case fi of (* lll *)
         1: rreckey(lib1);
         2: rreckey(lib2);
         3: rreckey(lib3);
      end
end; (* lrreckey *)

procedure lrenzyme(nam: name; var enz: enzymeptr);
(* read enzyme *)
var   it: item;
      fi: integer;
procedure renzyme(var thefile: text);
procedure lrenzkey(nam:name; var enz: enzkey);
begin (* lrenzkey *)
      with enz,it do begin
         checklib(thefile,nodeletter,fi,line);
         lrheader(thefile,fi,hea);
      end
end; (* lrenzkey *)
procedure lrsites(var sit: siteptr);
(* read dna sites of this enzyme *)
begin (* lrsites *)
      tvrslibrary(sitenode);
      sit:=nil;
      (* here we read in all the sites *)
      (* dummy *)
end; (* lrsites *)
begin (* renzyme *)
      with enz^,it do begin
         libgetto(thefile,fi,line);
         lrenzkey(nam,key);
         lrsites(sites)
      end
end; (* renzyme *)
begin (* lrenzyme *)
      finditem(enznode,nam,it,fi);
      if itemfound then case fi of (* lll *)
         1: renzyme(lib1);
         2: renzyme(lib2);
         3: renzyme(lib3);
      end
end; (* lrenzyme *)
*/

/**************************************************************************/
/* book writing procedures ************************************************/
/**************************************************************************/
/* these are called bw for book writes */

Static Void tvrsbook(future)
node future;
{
  /* procedure to print in the book the appropriate tree
     traversal characters: traverse to the new (future) node */
  step thisstep;
  char steps = 1;

  memcpy(thisstep, traversalchart[(long)pastbook][(long)future], sizeof(step));
  if (!strncmp(thisstep, illegaltraversal, sizeof(step))) {
    printf(" delila: program error:  illegal book traversal %12d to %12d\n",
	   (int)pastbook, (int)future);
    halt();
  }
  while (thisstep[steps-1] != '.') {
    switch (thisstep[steps-1]) {

    case 'o':
      fprintf(book.f, "organism");
      if (!versioninbook) {
	fprintf(book.f, " - book produced by delila %4.2f", version);
	versioninbook = true;
      }
      putc('\n', book.f);
      break;

    case 'c':
      fprintf(book.f, "chromosome\n");
      break;

    case 'm':
      fprintf(book.f, "marker\n");
      break;

    case 'd':
      fprintf(book.f, "dna\n");
      break;

    case 't':
      fprintf(book.f, "transcript\n");
      break;

    case 'g':
      fprintf(book.f, "gene\n");
      break;

    case 'p':
      fprintf(book.f, "piece\n");
      break;

    case 'r':
      fprintf(book.f, "recognition-class\n");
      break;

    case 'e':
      fprintf(book.f, "enzyme\n");
      break;

    case 's':
      fprintf(book.f, "site\n");
      break;
    }
    steps++;
  }
  pastbook = future;
}


Static Void bwbookheader(title)
line **title;
{
  /* write out the book title */
  datetimearray libheader;
  long i, FORLIM;

  bwstartline(&book);

  /* date of withdrawal */
  writedatetime(&book, datetime);

  /* date of library creation */
  fprintf(book.f, ", ");   /* finish date of withdrawal */
  switch (firstlibrary) {   /* lll */

  case 1:
    lrlibheader(&lib1, 1L, libheader);
    break;

  case 2:
    lrlibheader(&lib2, 2L, libheader);
    break;

  case 3:
    lrlibheader(&lib3, 3L, libheader);
    break;
  }
  writedatetime(&book, libheader);

  /* book title */
  if (*title != NULL) {
    if ((*title)->length != 0) {
      fprintf(book.f, ", ");   /* finish date of library creation */
      FORLIM = (*title)->length;
      for (i = 0; i < FORLIM; i++)
	putc((*title)->letters[i], book.f);
    }
    clearline(title);
  }

  /* finish the title line */
  putc('\n', book.f);
}


/* not implemented
procedure bwmarkers(var mar: markerptr);
(* write a set of marks (or only one) to the book *)
procedure bwmrky(var mar: markey);
(* write a marker key *)
begin
      tvrsbook(marnode);
      with mar do begin
         bwheader(hea);
         bwreference(ref);
         bwstate(sta);
         bwline  (phenotype);
      end
end;
procedure bwmardna(dna: dnaptr);
(* write marker dna *)
begin
      (* it may be possible to simply move several of the dna
      writing routines from bwpiedna (grabbase, writebase) into
      the low level library routines and use those *)
      (* dummy *)
end;
begin (* bwmarks *)
      while mar<>nil do begin
         if def.key.mar=on then begin
            with mar^ do begin
               bwmrky(key);
               bwmardna(dna)
            end
         end;
         clearmarker(mar)
      end
end;
*/

/*not implemented
procedure bwtrakey(var tra: trakey);
(* write a transcript key *)
begin
      if (def.key.tra = on) then begin
         tvrsbook(tranode);
         with tra do begin
            bwheader(book,hea);
            bwref(book,ref)
         end
      end
end;

procedure bwgenkey(var gen: genkey);
(* write a gene key *)
begin
      if (def.key.gen=on) then begin
         tvrsbook(gennode);
         with gen do begin
            bwheader(book,hea);
            bwref(book,ref)
         end
      end
end;
*/

/*not implemented
procedure bwreckey(var rec: reckey);
(* write a recognition key to the book *)
begin
      tvrsbook(recnode);
      with rec do begin
         bwheader(book,hea);
      end
end;

procedure bwenzyme(var enz: enzymeptr);
(* write an enzyme to the book *)
procedure bwenzkey(var enz: enzkey);
begin
      tvrsbook(enznode);
      with enz do begin
         bwheader(hea);
      end
end;
procedure bwsites(var sit: siteptr);
(* write a set of sites out to the book *)
begin
      (* dummy *)
end;
procedure expander(var sit: siteptr);
(* recursive copy of each site: when end of copy is reached
   on any one branch, print *)
begin
      (* dummy *)
end;
begin (* bwenzyme *)
      with enz^ do begin
         bwenzkey(key);
         if def.sit.expand = on then expander(sites)
                                else bwsites(sites)
      end
end;

procedure bwall(n: node; cut: integer);
(* write all of the object *)
(* first call must be specified, for this recursive routine *)
begin (* dummy *) end;

procedure bwevery(n: node);
(* write out every n within the currently specified structure *)
begin (* dummy *) end;
*/

/**************************************************************************/
/**************************************************************************/
/**************************************************************************/
/*OOO*/

/* begin module delila.writechangeset.describechangeset */
Static Void wchangedata(f, c_)
_TEXT *f;
changedata c_;
{
  /* write the changedata to f in shorthand notation */
  long i;   /* index to insertion */

  switch (c_.changetype) {

  case 'c':
    fprintf(f->f, "%c%ld%c", c_.baseold, c_.basecoo1, c_.basenew);
    break;

  case 'i':
    fprintf(f->f, "i%ld,%ld", c_.basecoo1, c_.basecoo2);
    if (c_.inserts > 0) {
      for (i = 0; i < c_.inserts; i++) {
	putc(c_.insert[i], f->f);
	/* Don't do this here because the changeset as written is like
	   a name:
	else write(f,'NOTHING');
	*/
      }
    }
    break;

  case 'd':
    fprintf(f->f, "d%ld,%ld", c_.basecoo1, c_.basecoo2);
    break;
  }
}


Static Void writechangeset(f, changes)
_TEXT *f;
changeset changes;
{
  /* write the changeset to file f in shorthand notation */
  long n;   /* index to changes */

  for (n = 1; n <= changes.number; n++) {
    if (n > 1)
      putc('.', f->f);
    wchangedata(f, changes.data[n-1]);
    /*
          with data[n] do case changetype of
             'c': write(f,baseold,basecoo1:1,basenew);
             'i': begin
                  write(f,'i',basecoo1:1,',',basecoo2:1);
                  if inserts > 0
                  then for i := 1 to inserts do write(f,insert[i])
                  (* Don't do this here because the changeset as written is like
                     a name:
                  else write(f,'NOTHING');
                  *)
             end;
             'd': write(f,'d',basecoo1:1,',',basecoo2:1)
          end;
    */
  }
}


Static Void checkchangeset(f, changes)
_TEXT *f;
changeset changes;
{
  /* write the changeset to file f in shorthand notation for INTERNAL
coordinates */
  long i;   /* index to insertion */
  long n;   /* index to changes */
  long FORLIM;
  changedata *WITH;
  long FORLIM1;

  FORLIM = changes.number;
  for (n = 1; n <= FORLIM; n++) {
    if (n > 1)
      putc('.', f->f);
    WITH = &changes.data[n-1];
    switch (WITH->changetype) {

    case 'c':
      fprintf(f->f, "%c%ld%c", WITH->baseold, WITH->internal1, WITH->basenew);
      break;

    case 'i':
      fprintf(f->f, "i%ld,%ld", WITH->internal1, WITH->internal2);
      if (WITH->inserts > 0) {
	FORLIM1 = WITH->inserts;
	for (i = 0; i < FORLIM1; i++) {
	  putc(WITH->insert[i], f->f);
	  /* Don't do this here because the changeset as written is like
                 a name:
              else write(f,'NOTHING');
              */
	}
      }
      break;

    case 'd':
      fprintf(f->f, "d%ld,%ld", WITH->internal1, WITH->internal2);
      break;
    }
  }
}


Static Void describechangeset(f, changes)
_TEXT *f;
changeset changes;
{
  /* describe in English the changeset to file f */
  long i;   /* index to insertion */
  long n;   /* index to changes */
  long FORLIM;
  changedata *WITH;
  long FORLIM1;

  if (changes.number == 0) {
    fprintf(f->f, "no changes");
    return;
  }
  FORLIM = changes.number;
  for (n = 1; n <= FORLIM; n++) {
    if (n > 1)
      fprintf(f->f, ", ");
    WITH = &changes.data[n-1];
    switch (WITH->changetype) {

    case 'c':
      fprintf(f->f, "at %ld %c->%c",
	      WITH->basecoo1, WITH->baseold, WITH->basenew);
      break;

    case 'i':
      fprintf(f->f, "insert ");
      if (WITH->inserts > 0) {
	FORLIM1 = WITH->inserts;
	for (i = 0; i < FORLIM1; i++)
	  putc(WITH->insert[i], f->f);
      } else
	fprintf(f->f, "NOTHING");
      fprintf(f->f, " between %ld and %ld", WITH->basecoo1, WITH->basecoo2);
      break;

    case 'd':
      fprintf(f->f, "delete %ld to %ld", WITH->basecoo1, WITH->basecoo2);
      break;
    }
  }
}


/* end module delila.writechangeset.describechangeset */

/* NOTE: SEE ALSO: linechangeset for output to the book */
/*OOO*/
/*OOO*/
/*OOO*/

/**************************************************************************/
/**************************************************************************/
/**************************************************************************/

/**************************************************************************/
/* instruction interpretation procedures **********************************/
/**************************************************************************/

Static boolean tvrschecks(futurecheck)
node futurecheck;
{
  /* this routine is to be used to check that the instructions are
     in proper order:
     'if tvrschecks(this-try) then continue-analysis-of-instructions;'

     in three cases we must advance (force) the node since no reads are
     done at this time. (library reads do a force for the other traversal
     routines) */
  boolean Result;

  Result = (strncmp(traversalchart[(long)pastcheck][(long)futurecheck],
		    illegaltraversal, sizeof(step)) != 0);
  if (futurecheck == marnode) {
    pastcheck = mardnanode;
    return Result;
  }
  if (futurecheck == pienode) {
    pastcheck = piednanode;
    return Result;
  }
  if (futurecheck == enznode)
    pastcheck = sitenode;
  else
    pastcheck = futurecheck;
  return Result;
}


#define pagelength      57   /* non-header lines on a page of listing. */
#define widinst         namelength
/* maximum width in characters of an instruction word */
#define minword         2   /* the minimum length delila word */
#define max1errors      33   /* maximum error number in pass 1 */
/*zzz111*/
/*EEE*/
#define max2errors      223   /* maximum error number in pass 2 */
#define maxerrors       10   /* listed per line in listing */
#define maxpositions    15
    /* the maximum number of position numbers per line */
#define maxnumbers      15   /* the maximum number of numberings per line */
#define numberlength    2   /* the length of the array numberword */


/* delila instruction types */
/* 1999 Mar 20 */
/* 1999 Mar 20 */
/* 1996 Aug 12 */
/* 1999 Mar 20 */
typedef enum {
  alldelila, arrdelila, begdelila, chrdelila, cledelila, comdelila, condelila,
  coodelila, cutdelila, defdelila, dirdelila, doudelila, elsdelila, enddelila,
  enzdelila, evedelila, expdelila, frodelila, gendelila, getdelila, haldelila,
  homdelila, ifdelila, keydelila, mardelila, moddelila, namdelila, notdelila,
  numdelila, offdelila, ondelila, orgdelila, outdelila, piedelila, recdelila,
  reddelila, samdelila, setdelila, sitdelila, sizdelila, thedelila, titdelila,
  todelila, tradelila, witdelila, nordelila, zerdelila, eodelila
} delilaword;
/* p2c: delila.p, line 3879:
 * Note: Line breaker spent 0.0 seconds, 5000 tries on line 5170 [251] */

/* instruction word spelling: */
typedef Char instword[widinst];

typedef struct elnrecord {
  /* errors on a line record */
  long pos[maxerrors];
  long err[maxerrors];
} elnrecord;

typedef struct plnrecord {
  /* dna position numbers on a line record */
  long pos[maxpositions];
  long psn[maxpositions];
  double rea[maxpositions];   /* real numbers on the line */
} plnrecord;

typedef struct nlnrecord {
  /* numbers on a line record */
  long pos[maxnumbers];
  long num[maxnumbers];
} nlnrecord;


typedef long position;
   /* make quicksort be happy but still standard */


#define shiftdown       1


#define showcase        false   /* show the cases */


#define ln10            2.30259
    /* natural log of 10 - for conversion to log base 10 */
#define epsilon         0.00001
    /* a small number to correct log base 10 errors */


#define precision       1e-7


/* Local variables for librarian: */
struct LOC_librarian {
  char pass;   /* the pass through the instructions */

  long pageline;   /* lines printed on this listing page */
  long pagenumber;   /* the page in listing */

  boolean pass1errors;   /* true if there were any errors in pass 1 */
  boolean pass2errors;   /* true if there were any errors in pass 2 */
  boolean warnings;   /* true for warnings in pass 2 */
  boolean error1list[max1errors + 1];   /* pass 1 errors */
  boolean error2list[max2errors - 200];   /* pass 2 errors */
  long numoferrors;   /* current number of errors per line */
  elnrecord errorline;   /* the errors on the current line */

  /* all of the words recognized by delila: */
  instword wordlist[48];

  long numbers[3];

  /* parsed parts of the instructions */
  Char chr;   /* storage for characters read from file inst */
  instword parsedword;   /* the latest word parsed from the instructions */
  long parsedlength;   /* the length of parsedword */
  long parsedlocation;   /* current location in parsedword */
  delilaword word;
  /* result of irword:   the translation
        into type delila of an instruction word parsed by spaces */
  long inumber;   /* an integer, result of routine irnumber */
  double rnumber;   /* a real number, result of routine irnumber */
  name keyname;   /* a key name */
  delilaword save;   /* to save the previous instruction word */

  line *usernotes;
  /* notes from the user to be inserted
                         into the next header specified */
  line *title;   /* the title of the book */
  boolean titleexists;
  /* true if a title was found in
     the first pass - a requirement */

  long instructioncount;   /* count number of instructions */
  long linecount;   /* count number of delila instruction lines */
  long lineposition;
  /* keeps track of where chr is being read
                        from a line in file inst.
                        used by ichread and error routines only */
  boolean correct;
  /* set by many routines as output to show
                       when the operation was successful */
  boolean eoinst;
  /* end of instruction- set to true by any ir routine
                      that finds a ';' */
  long parentheses;   /* the number of open parentheses */
  boolean comment;   /* true if we are inside a comment */
  long commentline;   /* the linecount where a comment was found */
  boolean quote;   /* true if we are inside a quote */
  boolean linebreak;
  /* true when at end of a line in inst
                         eof(inst) usually will not work since
                         ichread does an automatic readln(inst) */
  boolean significant;
  /* a significant non-blank, non- comment letter in
                           the instructions is now in chr */

  Char numberword[numberlength];
  /* the word 'number ',
        or the symbol '# '.   this is the symbol written to the book
        to number items.   used in procedure specify */

  /* what items are currently specified:
      0.5 = unspecified
     -0.5 = specified, not numbered
     integer = specified, numbered */
  double okspec, ckspec, mkspec, tkspec, gkspec, pkspec, rkspec, ekspec;

  /* interface between the library and the book.
     these variables temporarily store data from the library. */
  orgkey ok;
  chrkey ck;
  marker *mkoff, *mkon;
  trakey tk;
  genkey gk;
  piece *pk;   /* a piece of DNA sequence */
  reckey rk;
  enzyme *ek;

  /* variables that determine a request for a piece of dna */
  long fromposition;   /* the first base desired */
  long toposition;   /* the last base desired */
  /* the first base to provide from a circular piece of dna: */
  long cutposition;
  direction dirwanted;   /* orientation of the dna */

  /* pass 2 variables */
  long numofpositions;   /* number of position numbers on a line */
  plnrecord positionline;   /* the dna positions on the current line */
  long numofnumbers;   /* the number of numbers on a line */
  long numofchanges;
  /* the number of changes on a line, used to
     keep track of whether the mutations have been listed yet */
  nlnrecord numberline;   /* the numbers on the current line */

  /* not implemented
        choice: delilaword; (* the choice of an <if>. see also <condition>. *)
  */

  /* this is a set of those delilawords which represent
     structures in the library: */
  long structure[(long)eodelila / 32 + 2];

  /* the previous from position for the <SAME> */
  long previousfromposition;
  boolean sameusageisvalid;   /* if true, use of 'same' is valid */

  /* look for cases where both ends of a sequence have been reduced;
     warn the user in this case. */
  boolean reduced;

  /* amount to indent before writing information to listing */
  long indentlisting;

  direction coordinateside;
  /* which side of the coordinate system
     extra sequence should be added or deleted */

  long getcount;   /* count of the number of pieces gotten */
} ;

Local Void startheader(hea, LINK)
header *hea;
struct LOC_librarian *LINK;
{  /* starthea */
  /* initialize the values of a header */
  hea->fulnam = NULL;
  hea->note = NULL;
}  /* starthea */

Local Void initializedelila(LINK)
struct LOC_librarian *LINK;
{
  /* initialize the variables of delila */
  long i;

  versioninbook = false;   /* version has not been written yet */
  LINK->pagenumber = 0;   /* first page is 1 */

  /* set up conversion between letters and delilawords: */
  /* 123456789 123456789 123456789 123456789 123456789 */
  memcpy(LINK->wordlist[(long)alldelila],
    "all                                                                                                 ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)arrdelila],
    "arrowlength                                                                                         ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)begdelila],
    "beginning                                                                                           ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)chrdelila],
    "chromosome                                                                                          ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)cledelila],
    "cleave                                                                                              ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)comdelila],
    "complement                                                                                          ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)condelila],
    "continue                                                                                            ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)coodelila],
    "coordinate                                                                                          ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)cutdelila],
    "cut                                                                                                 ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)defdelila],
    "default                                                                                             ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)dirdelila],
    "direction                                                                                           ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)doudelila],
    "doubling                                                                                            ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)elsdelila],
    "else                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)enddelila],
    "ending                                                                                              ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)enzdelila],
    "enzyme                                                                                              ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)evedelila],
    "every                                                                                               ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)expdelila],
    "expand                                                                                              ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)frodelila],
    "from                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)gendelila],
    "gene                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)getdelila],
    "get                                                                                                 ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)haldelila],
    "halt                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)homdelila],
    "homologous                                                                                          ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)ifdelila],
    "if                                                                                                  ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)keydelila],
    "key                                                                                                 ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)mardelila],
    "marker                                                                                              ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)moddelila],
    "modify                                                                                              ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)namdelila],
    "name                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)notdelila],
    "note                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)numdelila],
    "numbering                                                                                           ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)offdelila],
    "off                                                                                                 ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)ondelila],
    "on                                                                                                  ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)orgdelila],
    "organism                                                                                            ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)outdelila],
    "out-of-range                                                                                        ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)piedelila],
    "piece                                                                                               ",
    sizeof(instword));
  /*
        wordlist[recdelila]:='recognition-class   ';
  */
  memcpy(LINK->wordlist[(long)reddelila],
    "reduce-range                                                                                        ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)samdelila],
    "same                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)setdelila],
    "set                                                                                                 ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)sitdelila],
    "site                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)sizdelila],
    "size                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)thedelila],
    "then                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)titdelila],
    "title                                                                                               ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)todelila],
    "to                                                                                                  ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)tradelila],
    "transcript                                                                                          ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)witdelila],
    "with                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)zerdelila],
    "zero                                                                                                ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)nordelila],
    "normal                                                                                              ",
    sizeof(instword));
  memcpy(LINK->wordlist[(long)eodelila],
    "end-of-delila-words                                                                                 ",
    sizeof(instword));

  /* no errors have been detected yet: */
  LINK->pass1errors = false;
  LINK->pass2errors = false;
  for (i = 0; i <= max1errors; i++)
    LINK->error1list[i] = false;
  for (i = 0; i <= max2errors - 201; i++)
    LINK->error2list[i] = false;
  /* no special conditions yet: */
  LINK->warnings = false;

  LINK->title = NULL;
  LINK->titleexists = false;
  longname = NULL;
  LINK->usernotes = NULL;
  memcpy(LINK->numberword, "# ", (long)numberlength);
  P_addset(P_expset(LINK->numbers, 0L), '0');
  P_addset(LINK->numbers, '1');
  P_addset(LINK->numbers, '2');
  P_addset(LINK->numbers, '3');
  P_addset(LINK->numbers, '4');
  P_addset(LINK->numbers, '5');
  P_addset(LINK->numbers, '6');
  P_addset(LINK->numbers, '7');
  P_addset(LINK->numbers, '8');
  P_addset(LINK->numbers, '9');
  P_addset(P_expset(LINK->structure, 0L), (int)orgdelila);
  P_addset(LINK->structure, (int)chrdelila);
  P_addset(LINK->structure, (int)mardelila);
  P_addset(LINK->structure, (int)tradelila);
  P_addset(LINK->structure, (int)gendelila);
  P_addset(LINK->structure, (int)piedelila);
  /*not implemented  ,
                    recdelila, enzdelila*/
  getmarker(&LINK->mkoff);
  LINK->mkon = NULL;
  LINK->pk = (piece *)Malloc(sizeof(piece));
  LINK->ek = (enzyme *)Malloc(sizeof(enzyme));

  /* start all lines at nil */
  startheader(&LINK->ok.hea, LINK);
  LINK->ok.mapunit = NULL;
  startheader(&LINK->ck.hea, LINK);
  startheader(&LINK->mkoff->key.hea, LINK);
  LINK->mkoff->key.phenotype = NULL;
  LINK->mkoff->key.next = NULL;
  startheader(&LINK->tk.hea, LINK);
  startheader(&LINK->gk.hea, LINK);
  startheader(&LINK->pk->key.hea, LINK);
  startheader(&LINK->rk.hea, LINK);
  startheader(&LINK->ek->key.hea, LINK);

  /* unspecify all the items.  see procedure unspec */
  LINK->okspec = 0.5;
  LINK->ckspec = 0.5;
  LINK->mkspec = 0.5;
  LINK->tkspec = 0.5;
  LINK->gkspec = 0.5;
  LINK->pkspec = 0.5;
  LINK->rkspec = 0.5;
  LINK->ekspec = 0.5;

  LINK->indentlisting = instwidth * 2 + 4;
      /* extra space after each inst number */

  LINK->coordinateside = plus;
  LINK->getcount = 0;

}  /* initializedelila */

Local Void pageheader(LINK)
struct LOC_librarian *LINK;
{
  /* write delila page header */
  LINK->pageline = 1;
  LINK->pagenumber++;
  fprintf(listing.f, "   ");
  writedatetime(&listing, datetime);
  fprintf(listing.f, "     delila %4.2f     pass %d           page %ld\n\n",
	  version, LINK->pass, LINK->pagenumber);
  LINK->pageline += 2;
}

Local Void startlistingline(LINK)
struct LOC_librarian *LINK;
{
  /* start an instruction listing line */
  if (!BUFEOF(inst.f)) {
    LINK->linecount++;
    fprintf(listing.f, " %*ld %*ld  ",
	    instwidth, LINK->linecount, instwidth, LINK->instructioncount);
  }
}

Local Void initreadinst(LINK)
struct LOC_librarian *LINK;
{
  /* prepare to read the instructions starting from the top */
  LINK->eoinst = false;   /* not at end of instruction */
  LINK->parentheses = 0;   /* no open ( yet */
  LINK->comment = false;   /* not inside a comment */
  LINK->quote = false;   /* not inside a quote */
  LINK->chr = ' ';
  LINK->instructioncount = 1;
  LINK->linecount = 0;
  LINK->lineposition = 0;   /* before the zeroth character */
  LINK->numoferrors = 0;
  LINK->numofpositions = 0;
  LINK->numofnumbers = 0;
  LINK->numofchanges = 0;
  /* make sure that we are normal coordinate system by default */
  def.coo = coornormal;

  pageheader(LINK);
  fprintf(listing.f,
	  "    Parent               Grand Parent         Library\n");
  fprintf(listing.f, "#   Library Date/Time:  ");
  fprintf(listing.f, " Library Date/Time:");
  fprintf(listing.f, "   Title:\n");
  LINK->pageline += 2;
  /* lll */
  if (copylibname(&listing, &lib1, 1L))
    LINK->pageline++;
  if (copylibname(&listing, &lib2, 2L))
    LINK->pageline++;
  if (copylibname(&listing, &lib3, 3L))
    LINK->pageline++;
  fprintf(listing.f, "\n   inst statement\n");
  fprintf(listing.f, "   line number   \n");
  LINK->pageline += 3;
  startlistingline(LINK);
  longnameexists = false;

  /* make sure that there is no previous name from the first pass: */
  clearname(lastpiecename);

  /* make sure that there are no mutations from the first pass: */
  mutations.number = 0;   /* force */

  /* clear the pieces */
  LINK->pk->dna = NULL;
  libpie->dna = NULL;
  clearpiece(&LINK->pk);
  clearpiece(&libpie);

  /* initialize defaults */

  def.key.note = on;
  def.key.mar = on;
  def.key.gen = on;
  def.key.tra = on;
  def.sit.expand = on;
  def.sit.modify = off;
  def.sit.cleave = off;
  def.defout = rhalt;
  def.num.sta = on;
  /* turn OFF all numbering: */
  for (indnum = orgnum;
       (long)indnum <= (long)enznum;
       indnum = (numberedstructure)((long)indnum + 1))
    def.num.str[(long)indnum] = off;
  /* turn on only pieces initially  [1997 Jan 10] */
  def.num.str[(long)pienum] = on;
  def.num.item = 0;   /* first value will be 1 */
  def.doubling = off;
  def.arrowlength = 1.5;
  /* default values for variables for making marksdelila file */
  insertlowerbits = -1.3;   /* lowerbits for insertion symbol */
  insertupperbits = -0.1;   /* upperbits for insertion symbol */
  deletelowerbits = -1.3;   /* lowerbits for deletion symbol */
  deleteupperbits = -0.1;   /* upperbits for deletion symbol */
  changelowerbits = 0.3;   /* lowerbits for change symbol */
  /* upperbits for change symbol: */
  changeupperbits = def.arrowlength + changelowerbits;

}  /* initreadinst */

Local boolean awarning(e, LINK)
long e;
struct LOC_librarian *LINK;
{
  /* this defines which errors are actually warnings */
  return (e == 206 || e == 208 || e == 209 || e == 210 || e == 212 ||
	  e == 213 || e == 215 || e == 216 || e == 219 || e == 220 ||
	  e == 221 || e == 3);
}

Local Void writepasserrors(listing, pass, LINK)
_TEXT *listing;
long pass;
struct LOC_librarian *LINK;
{
  /* write out what the error numbers marked in the listing
     correspond to in english */
  long e;   /* index for errors */
  long i;   /* index to write piece key name */
  boolean warn1;   /* warnings in pass 1 must be listed for pass 2... */
  name *WITH;
  long FORLIM1;

  if (pass == 1 && !LINK->pass1errors)
    fprintf(listing->f, "No syntax errors found.\n");
  if (pass == 2 && !LINK->pass2errors)
    fprintf(listing->f, "No extraction errors found.\n");

  warn1 = (pass == 2 && LINK->error1list[3]);
  if (pass == 1 || warn1) {
    if (LINK->pass1errors || warn1) {
      fprintf(listing->f, "Key to error and warning numbers:\n");
      for (e = 0; e <= max1errors; e++) {
	if (LINK->error1list[e]) {
	  if (awarning(e, LINK))
	    fprintf(listing->f, "WARNING!  ");
	  fprintf(listing->f, "%4ld: ", e);
	  switch (e) {

	  case 0:
	    fprintf(listing->f,
		    "I do not know how to do this instruction yet, sorry");
	    break;

	  case 1:
	    fprintf(listing->f,
		    "Instruction longer than expected (missing semicolon)");
	    break;

	  case 2:
	    fprintf(listing->f, "I can not recognize this word");
	    break;

	  case 3:
	    fprintf(listing->f, "Warning: this title was ignored");
	    break;

	  case 4:
	    fprintf(listing->f, "I can not recognize this integer");
	    break;

	  case 6:
	    fprintf(listing->f,
	      "You are missing a specification (illegal tree traversal)");
	    break;

	  case 7:
	    fprintf(listing->f, "This word is not allowed here");
	    break;

	  case 8:
	    fprintf(listing->f, "A cut is only allowed with a piece");
	    break;

	  case 9:
	    fprintf(listing->f, "This word is too long for me (>%3ld chars)",
		    (long)widinst);
	    break;

	  case 10:
	    fprintf(listing->f,
		    "Unclosed comment found at end of instructions.\n");
	    fprintf(listing->f, "%6cThe comment started on line %ld.",
		    ' ', LINK->commentline);
	    break;

	  case 11:
	    fprintf(listing->f, "Unclosed ( or ) in this instruction");
	    break;

	  case 12:
	    fprintf(listing->f, "Unclosed quote");
	    break;

	  case 13:
	    fprintf(listing->f, "No closing ;");
	    break;

	  case 14:
	    fprintf(listing->f, "This key name is too long (>%3ld chars)",
		    (long)namelength);
	    break;

	  case 15:
	    fprintf(listing->f, "The statement ended before I expected it to");
	    break;

	  case 16:
	    fprintf(listing->f, "Quote expected");
	    break;

	  case 17:
	    fprintf(listing->f, "A title is required");
	    break;

	  case 18:
	    fprintf(listing->f,
	      "\"from same\" is not allowed; use it only as \"to same\"");
	    break;

	  case 19:
	    fprintf(listing->f,
		    "mutation: Change must be identified by one of: acgtdi\n");
	    fprintf(listing->f,
	      "%6c          Instead, an illegal change character was found",
	      ' ');
	    break;

	  case 20:
	    fprintf(listing->f, "Old base must be: a, c, g, t");
	    break;

	  case 21:
	    fprintf(listing->f, "New base must be: a, c, g, t");
	    break;

	  case 22:
	    fprintf(listing->f,
		    "Insertion bases must be one of a, c, g, or t.");
	    break;

	  case 23:
	    fprintf(listing->f,
	      "A comma (,) is expected between coordinates for deletion.");
	    break;

	  case 24:
	    fprintf(listing->f,
	      "No more than %ld insertion bases allowed, increase constant insertmax",
	      (long)insertmax);
	    break;

	  case 25:
	    fprintf(listing->f,
	      "A comma (,) is expected between coordinates for insertion.");
	    break;

	  case 26:
	    fprintf(listing->f,
		    "A number was expected but no digits were found.");
	    break;

	  case 27:
	    fprintf(listing->f,
	      "First coordinate number must not be larger than second:\n");
	    fprintf(listing->f,
		    "      reverse their order.  See libdef for the reason.");
	    break;

	  case 28:
	    fprintf(listing->f,
	      "Too many changes requested, increase constant changesetmax.");
	    break;

	  case 29:
	    fprintf(listing->f, "Extra dots not allowed.");
	    break;

	  case 30:
	    fprintf(listing->f, "Unidentified change command.");
	    break;

	  case 31:
	    fprintf(listing->f,
		    "Numbers cannot have more than 1 sign (+ or -).");
	    break;

	  case 32:
	    fprintf(listing->f,
	      "Insertion complement symbol must be before insertion sequence.");
	    break;

	  case 33:
	    fprintf(listing->f,
	      "Non-printable ASCII character found.  Eg: tabs not allowed.");
	    break;
	    /*zzz111*/
	    /*EEE*/
	  }
	  putc('\n', listing->f);
	}
      }
    }
  }
  /*
        else (* if pass = 2 then *) begin
  */
  /* 2001 Mar 28 pass 2 errors must be written independently of pass 1
     so that the warning about double titles does not block errors in
     pass 2 from being listed */
  if (pass == 2) {
    if (LINK->pass2errors || LINK->warnings) {
      fprintf(listing->f, "Key to error or warning numbers:\n");
      for (e = 201; e <= max2errors; e++) {
	if (LINK->error2list[e-201]) {
	  fprintf(listing->f, "%4ld: ", e);
	  if (awarning(e, LINK))
	    fprintf(listing->f, "WARNING!  ");
	  switch (e) {

	  case 201:
	    fprintf(listing->f, "I can not find this item in the library");
	    break;

	  case 202:
	    fprintf(listing->f, "This item was not previously specified");
	    break;

	  case 203:
	    fprintf(listing->f, "Out of range and default range = halt");
	    break;

	  case 204:
	    fprintf(listing->f,
		    "Positions not consistent with requested direction");
	    break;

	  case 205:
	    fprintf(listing->f,
		    "This thing was not on the previously specified piece");
	    break;

	  case 206:
	    fprintf(listing->f, "We do not know this limit");
	    break;

	  case 207:
	    fprintf(listing->f,
		    "For cutting, the piece must be circular. it is linear");
	    break;

	  case 208:
	    fprintf(listing->f, "Out of range and default range = reduce");
	    break;

	  case 209:
	    fprintf(listing->f, "Out of range and default range = continue");
	    break;

	  case 210:
	    fprintf(listing->f,
		    "Piece had two end reductions: length will be 1 base!");
	    printf("Piece ");
	    WITH = &LINK->pk->key.hea.keynam;
	    FORLIM1 = WITH->length;
	    for (i = 0; i < FORLIM1; i++)
	      putchar(WITH->letters[i]);
	    printf(" had two end reductions: length will be 1 base!\n");
	    break;

	  case 211:
	    fprintf(listing->f,
		    "The base you want to mutate is not what you said it is");
	    break;

	  case 212:
	    fprintf(listing->f,
		    "mutation: inserted sequence alters coordinate system");
	    break;

	  case 213:
	    fprintf(listing->f,
		    "mutation: deleted sequence alters coordinate system");
	    break;

	  case 214:
	    fprintf(listing->f,
		    "mutation: the initial and final bases are the same,\n");
	    fprintf(listing->f, "      so you did not request any change!");
	    break;

	  case 215:
	    fprintf(listing->f,
	      "mutation: Requested coordinate off piece in 5' direction");
	    break;

	  case 216:
	    fprintf(listing->f,
	      "mutation: requested coordinate off piece in 3' direction");
	    break;

	  /* no longer valid:
217: write(listing,'mutation: The requested coordinates are out of order.');
*/
	  case 218:
	    fprintf(listing->f,
		    "mutation: The requested coordinates cannot be equal.");
	    break;

	  case 219:
	    fprintf(listing->f, "There will be no change to the sequence!");
	    break;

	  case 220:
	    fprintf(listing->f,
		    "The entire sequence was deleted!  NO PIECE WAS OUTPUT!");
	    break;

	  case 221:
	    fprintf(listing->f,
		    "Deletion outside of sequence will have no effect!");
	    break;

	  case 222:
	    fprintf(listing->f, "Overlapping changes are not allowed.");
	    break;

	  case 223:
	    fprintf(listing->f, "Booksize would exceed %ld bases.", maxbook);
	    break;
	  }
	  putc('\n', listing->f);
	}
      }
    }
  }
  putc('\n', listing->f);
}

Local Void copyfile(fromfile, tofile)
_TEXT *fromfile, *tofile;
{
  /* copy one file into the other.
     no resets or rewrites are done */
  Char ch;

  while (!BUFEOF(fromfile->f)) {
    while (!P_eoln(fromfile->f)) {
      ch = getc(fromfile->f);
      if (ch == '\n')
	ch = ' ';
      putc(ch, tofile->f);
    }
    fscanf(fromfile->f, "%*[^\n]");
    getc(fromfile->f);
    putc('\n', tofile->f);
  }
}


Local Void bookhalt(LINK)
struct LOC_librarian *LINK;
{
  /* put a 'halt' at the top of the book, and warn the user */
  _TEXT bookcopy;

  bookcopy.f = NULL;
  *bookcopy.name = '\0';
  if (LINK->pass == 2) {  /* copy away the book */
    if (*book.name != '\0') {
      if (book.f != NULL)
	book.f = freopen(book.name, "r", book.f);
      else
	book.f = fopen(book.name, "r");
    } else
      rewind(book.f);
    if (book.f == NULL)
      _EscIO2(FileNotFound, book.name);
    RESETBUF(book.f, Char);
    if (*bookcopy.name != '\0') {
      if (bookcopy.f != NULL)
	bookcopy.f = freopen(bookcopy.name, "w", bookcopy.f);
      else
	bookcopy.f = fopen(bookcopy.name, "w");
    } else {
      if (bookcopy.f != NULL)
	rewind(bookcopy.f);
      else
	bookcopy.f = tmpfile();
    }
    if (bookcopy.f == NULL)
      _EscIO2(FileNotFound, bookcopy.name);
    SETUPBUF(bookcopy.f, Char);
    copyfile(&book, &bookcopy);
  }
  if (*book.name != '\0') {
    if (book.f != NULL)
      book.f = freopen(book.name, "w", book.f);
    else
      book.f = fopen(book.name, "w");
  } else {
    if (book.f != NULL)
      rewind(book.f);
    else
      book.f = tmpfile();
  }
  if (book.f == NULL)
    _EscIO2(FileNotFound, book.name);
  SETUPBUF(book.f, Char);
  fprintf(book.f, "halt: error in Delila pass %d\n", LINK->pass);
  if (LINK->pass == 2) {
    if (*bookcopy.name != '\0') {
      if (bookcopy.f != NULL)
	bookcopy.f = freopen(bookcopy.name, "r", bookcopy.f);
      else
	bookcopy.f = fopen(bookcopy.name, "r");
    } else
      rewind(bookcopy.f);
    if (bookcopy.f == NULL)
      _EscIO2(FileNotFound, bookcopy.name);
    RESETBUF(bookcopy.f, Char);
    copyfile(&bookcopy, &book);
  }
  if (bookcopy.f != NULL)
    fclose(bookcopy.f);
}


Local Void iwritenumber(c_, n, LINK)
Char c_;
long n;
struct LOC_librarian *LINK;
{
  /* write a number n to listing, move the line position */
  /* the number is proceeded by the character c */
  long spots;   /* positions moved */
  long absn;   /* absolute value of n */
  long power = 10;   /* a power of 10 */

  if (n >= 0) {
    spots = 2;
    absn = n;
  } else {
    spots = 3;
    absn = -n;
  }
  /* perform log function */
  while (absn >= power) {
    power *= 10;
    spots++;
  }
  fprintf(listing.f, "%c%*ld", c_, (int)(spots - 1), n);
  LINK->lineposition += spots;
}

Local Void rwritenumber(c_, n, LINK)
Char c_;
double n;
struct LOC_librarian *LINK;
{
  /* write a real number n to listing, move the line position */
  /* the number is proceeded by the character c */
  long spots;   /* positions moved */
  long power = 10;   /* a power of 10 */
  double absn;   /* absolute value of n */

  if (n >= 0) {
    spots = 2;
    absn = n;
  } else {
    spots = 3;
    absn = -n;
  }
  /* perform log function */
  while (absn >= power) {
    power *= 10;
    spots++;
  }
  spots += 2;   /* decimal and two digits */
  fprintf(listing.f, "%c%*.2f", c_, (int)(spots - 1), n);
  LINK->lineposition += spots;
}

/* error routines *********************************************************/

Local Void error(err, LINK)
long err;
struct LOC_librarian *LINK;
{
  /* enter an error in to 'errorline' recording the error number
     and where it occured on the line (ie. lineposition)
     since pass 2 implies a perfect pass 1, this routine is (usually)
     only active during pass 1.  so in pass 2 this routine checks that
     the code is running correctly.
     error sets the appropriate passerror:=true
     correct is set */
  if (awarning(err, LINK))
    printf("WARNING %ld\n", err);
  else
    printf("ERROR %ld\n", err);
  /*crash;*/
  /*zzzfff*/
  /* make warnings for some numbers, death for others */
  LINK->correct = false;
  if (awarning(err, LINK)) {
    LINK->warnings = true;
    LINK->correct = true;
  }
  LINK->numoferrors++;
  if (LINK->numoferrors <= maxerrors) {
    LINK->errorline.pos[LINK->numoferrors-1] = LINK->lineposition;
    LINK->errorline.err[LINK->numoferrors-1] = err;
    if (LINK->pass == 1) {
      LINK->pass1errors = (LINK->pass1errors || !LINK->correct);
      LINK->error1list[err] = true;
    } else {
      LINK->pass2errors = (LINK->pass2errors || !LINK->correct);
      LINK->error2list[err-201] = true;
    }
  }
  /* pass=2 */
  if (debugging)
    fprintf(debug.f, "error(%4ld)\n", err);
}

/* begin module delila.plural */
Local Void plural(thefile, number, blank, LINK)
_TEXT *thefile;
long number;
Char blank;
struct LOC_librarian *LINK;
{
  /* if the number is not 1, return an s.  Otherwise return the blank character
*/
  if (number != 1)
    putc('s', thefile->f);
  else {
    putc(blank, thefile->f);
    /*
       else write(thefile,'-')
    */
  }
}  /* plural */

/* end module delila.plural version = 2.09; (@ of rembla.p 1995 dec 21 */

Local Void writeerrors(LINK)
struct LOC_librarian *LINK;
{
  /* write out errors for a line from 'errorline'.
     clear errorline. indicate location of errors with a ^ */
  /*EEPP*/
  long another;   /* another message is needed */
  long e;   /* counter of number of errors */
  long errornumber = 1;   /* the ith error */
  long errorsonline = 0;   /* number of errors found on a line */
  long warningsonline = 0;   /* number of warnings found on a line */
  long FORLIM;

  if (LINK->numoferrors == 0)
    return;

  FORLIM = LINK->numoferrors;
  for (e = 0; e < FORLIM; e++) {
    if (!awarning(LINK->errorline.err[e], LINK))
      errorsonline++;
    else
      warningsonline++;
  }
  /*
writeln(listing,'e = ',e:1);
writeln(listing,'errorsonline = ',errorsonline:1);
writeln(listing,'warningsonline = ',warningsonline:1);
*/
  if (errorsonline > 0) {
    fprintf(listing.f, " ---error");
    plural(&listing, errorsonline, '-', LINK);
    fprintf(listing.f, "------");   /* 16 characters */
  } else {
    fprintf(listing.f, " ---warning");
    plural(&listing, warningsonline, '-', LINK);
    fprintf(listing.f, "----");   /* 16 characters */
  }

  /*
           write(listing,'    ---error(s)----'); (* 16 characters *)
  */

  LINK->lineposition = 1;
  while (LINK->numoferrors > 0 && errornumber <= maxerrors) {
    if (LINK->lineposition < LINK->errorline.pos[errornumber-1]) {
      LINK->lineposition++;
      putc('-', listing.f);
      continue;
    }
    iwritenumber('^', LINK->errorline.err[errornumber-1], LINK);
    if (LINK->errorline.err[errornumber-1] == 19 ||
	(LINK->errorline.err[errornumber-1] >= 21 &&
	 LINK->errorline.err[errornumber-1] <= 23) ||
	LINK->errorline.err[errornumber-1] == 25 ||
	LINK->errorline.err[errornumber-1] == 30 ||
	LINK->errorline.err[errornumber-1] == 222 ||
	LINK->errorline.err[errornumber-1] == 218 ||
	LINK->errorline.err[errornumber-1] == 217 ||
	LINK->errorline.err[errornumber-1] == 216 ||
	LINK->errorline.err[errornumber-1] == 215 ||
	LINK->errorline.err[errornumber-1] == 211) {
      /*EEE*/
      another = LINK->errorline.err[errornumber-1];
    }

    errornumber++;
    LINK->numoferrors--;
  }

  if (LINK->numoferrors > 0)
    fprintf(listing.f, " and other errors");
  LINK->numoferrors = 0;
  putc('\n', listing.f);

  /*
writeln(listing);
writeln(listing,'lineposition = ',lineposition:1);
write  (listing,'                ');
writeln(listing,'123456789 123456789 123456789 123456789 123456789 123456789 123456789 123456789');
write  (listing,'                ');
writeln(listing,'         1         2         3         4         5         6         7         8');
*/

  LINK->pageline++;
  /* special additional information for mutations */

  if (another == 19) {
    fprintf(listing.f, " Change must be identified by one of: acgtdi\n");
    fprintf(listing.f,
	    " Instead, the illegal change character \"%c\" was found\n",
	    mutischar);
    LINK->pageline++;
  }

  if (another == 21) {
    fprintf(listing.f, " \n");
    fprintf(listing.f, " Change bases must be one of a, c, g, or t.\n");
    fprintf(listing.f, " Instead, \"%c\" was found\n", mutischar);
    LINK->pageline++;
  }

  if (another == 22) {
    fprintf(listing.f, " Insertion bases must be one of a, c, g, or t.\n");
    fprintf(listing.f, " Instead, \"%c\" was found\n", mutischar);
    LINK->pageline++;
  }

  if (another == 25) {
    fprintf(listing.f, " A comma (,) must separate insertion parts.\n");
    fprintf(listing.f, " Instead, \"%c\" was found\n", mutischar);
    LINK->pageline++;
  }

  if (another == 23) {
    fprintf(listing.f, " A comma (,) must separate deletion parts.\n");
    fprintf(listing.f, " Instead, \"%c\" was found\n", mutischar);
    LINK->pageline++;
  }
  if (another == 30) {
    fprintf(listing.f, " Unidentified change command:");
    fprintf(listing.f, " \"%c\"\n", mutischar);
    LINK->pageline++;
  }

  if (another == 211) {
    fprintf(listing.f,
      "On the positively oriented strand, the old base at %ld is NOT %c!  It is %c.\n",
      mutposition1, mutnotchar, mutischar);
    LINK->pageline++;
  }
  if (another == 215) {
    fprintf(listing.f,
      "The requested coordinate at %ld is off the piece in the 5' direction\n",
      mutposition1);
    LINK->pageline++;
  }
  if (another == 216) {
    fprintf(listing.f,
      "The requested coordinate at %ld is off the piece in the 3' direction\n",
      mutposition1);
    LINK->pageline++;
  }
  if (another == 217) {
    fprintf(listing.f,
	    "The requested coordinates %ld and %ld are out of order.\n",
	    mutposition1, mutposition2);
    LINK->pageline++;
  }
  if (another == 218) {
    fprintf(listing.f,
	    "The requested coordinates \"%ld,%ld\" cannot be equal.\n",
	    mutposition1, mutposition2);
    LINK->pageline++;
  }
  /*EEE*/
  if (another != 222)
    return;

  fprintf(listing.f, "Overlapping changes: ");
  wchangedata(&listing, mutcd1);
  fprintf(listing.f, " overlaps ");
  wchangedata(&listing, mutcd2);
  putc('\n', listing.f);
  /*zzzppp*/
  LINK->pageline++;

  /*
writeln(listing,'123456789 123456789 123456789 123456789 123456789 123456789 123456789 123456789');
*/
}

/* pass 2 number routines ***********************************************/

Local Void ivaluenumber(p, LINK)
long p;
struct LOC_librarian *LINK;
{
  /* put a number into the number line array
     like procedure error */
  LINK->numofnumbers++;
  if (LINK->numofnumbers <= maxnumbers) {
    LINK->numberline.pos[LINK->numofnumbers-1] = LINK->lineposition - 1;
    LINK->numberline.num[LINK->numofnumbers-1] = p;
  }
  if (debugging)
    fprintf(debug.f, "ivaluenumber%5ld\n", p);
}

Local Void writenumbers(LINK)
struct LOC_librarian *LINK;
{
  /* write the numbers of number line out
     like procedure writeerrors */
  long i;
  long number = 1;   /* the ith number */
  long FORLIM;

  if (LINK->numofnumbers == 0)
    return;
  FORLIM = LINK->indentlisting;
  for (i = 1; i <= FORLIM; i++)
    putc(' ', listing.f);
  LINK->lineposition = 0;
  while (LINK->numofnumbers > 0 && number <= maxnumbers) {
    if (LINK->lineposition >= LINK->numberline.pos[number-1]) {
      iwritenumber('#', LINK->numberline.num[number-1], LINK);
      number++;
      LINK->numofnumbers--;
    } else {
      LINK->lineposition++;
      putc(' ', listing.f);
    }
  }
  if (LINK->numofnumbers > 0)
    fprintf(listing.f, "and others (sorry)");
  LINK->numofnumbers = 0;
  putc('\n', listing.f);
  LINK->pageline++;
}

/**************************************************************************/
/**************************************************************************/
/**************************************************************************/

/*OOO*/
/*OOO*/
/*OOO*/
/*OOO*/
/*OOO*/
/*OOO*/

/**************************************************************************/
/* pass 2 position routines ***********************************************/
/**************************************************************************/

Local Void ivalueposition(p, LINK)
long p;
struct LOC_librarian *LINK;
{
  /* put a position into the position line array
     like procedure error */
  LINK->numofpositions++;
  if (LINK->numofpositions <= maxpositions) {
    LINK->positionline.pos[LINK->numofpositions-1] = LINK->lineposition - 1;
    LINK->positionline.psn[LINK->numofpositions-1] = p;
    LINK->positionline.rea[LINK->numofpositions-1] = p;
  }
  if (debugging)
    fprintf(debug.f, "ivalueposition%5ld\n", p);
}

Local Void rvalueposition(r, LINK)
double r;
struct LOC_librarian *LINK;
{
  /* put a real number into the position line array
     like procedure error */
  LINK->numofpositions++;
  if (LINK->numofpositions > maxpositions)
    return;
  LINK->positionline.pos[LINK->numofpositions-1] = LINK->lineposition - 1;
  /* flag for real number: */
  LINK->positionline.psn[LINK->numofpositions-1] = (long)floor(r + 0.5) + 10;
  LINK->positionline.rea[LINK->numofpositions-1] = r;
}

Local Void writepositions(LINK)
struct LOC_librarian *LINK;
{
  /* write the positions of position line out
     like procedure writeerrors */
  long i;
  long number = 1;   /* the ith number */
  long FORLIM;

  if (LINK->numofpositions == 0)
    return;
  FORLIM = LINK->indentlisting;
  for (i = 1; i <= FORLIM; i++)
    putc(' ', listing.f);
  LINK->lineposition = 1;
  while (LINK->numofpositions > 0 && number <= maxpositions) {
    if (LINK->lineposition < LINK->positionline.pos[number-1]) {
      LINK->lineposition++;
      putc(' ', listing.f);
      continue;
    }
    if (LINK->positionline.psn[number-1] !=
	(long)floor(LINK->positionline.rea[number-1] + 0.5))
      rwritenumber('^', LINK->positionline.rea[number-1], LINK);
    else
      iwritenumber('^', LINK->positionline.psn[number-1], LINK);
    number++;
    LINK->numofpositions--;
  }
  if (LINK->numofpositions > 0)
    fprintf(listing.f, "and others (sorry)");
  LINK->numofpositions = 0;
  putc('\n', listing.f);
  LINK->pageline++;
}

Local Void writechanges(LINK)
struct LOC_librarian *LINK;
{
  /* write out mutational changes about the instruction */
  long i;   /* index for writing spaces */

  if (LINK->numofchanges > 0) {
    fprintf(listing.f, "Mutation");
    if (mutations.number > 1)
      fprintf(listing.f, "s:");
    else
      fprintf(listing.f, ": ");
    /* +6 is normal spacing, -11 is "Mutations: " */
    for (i = 1; i <= instwidth * 2 - 6; i++)
      putc(' ', listing.f);
    describechangeset(&listing, mutations);
    putc('\n', listing.f);
  }
  LINK->numofchanges = 0;
}

Local Void writelineinformation(LINK)
struct LOC_librarian *LINK;
{
  /* write out information about the previous line */
  writenumbers(LINK);
  writepositions(LINK);
  writechanges(LINK);
}

/* Local variables for readinstruction: */
struct LOC_readinstruction {
  struct LOC_librarian *LINK;
} ;

Local node noder(word, LINK)
delilaword *word;
struct LOC_readinstruction *LINK;
{
  /* convert a delila to a node */
  node Result;

  switch (*word) {

  case orgdelila:
    Result = orgnode;
    break;

  case chrdelila:
    Result = chrnode;
    break;

  case mardelila:
    Result = marnode;
    break;

  case tradelila:
    Result = tranode;
    break;

  case gendelila:
    Result = gennode;
    break;

  case piedelila:
    Result = pienode;
    break;

  case recdelila:
    Result = recnode;
    break;

  case enzdelila:
    Result = enznode;
    break;
  }
  return Result;
}

Local Void ichread(LINK)
struct LOC_readinstruction *LINK;
{
  /* read a single character from the instruction file into chr */
  /* this and error routines are the only routines which know where we
     are in the instruction file */
  LINK->LINK->linebreak = false;
  /* old loop:
        while (eoln(inst) and (not eof(inst))) do begin  */
  /* new loop version: */
  if (!BUFEOF(inst.f)) {
    if (P_eoln(inst.f)) {
      do {
	if (debugging)
	  fprintf(listing.f, "ichread: LINE BREAK\n");
	LINK->LINK->linebreak = true;
	fscanf(inst.f, "%*[^\n]");
	getc(inst.f);
	putc('\n', listing.f);
	LINK->LINK->pageline++;
	if (LINK->LINK->pass == 2)
	  writelineinformation(LINK->LINK);
	writeerrors(LINK->LINK);
	if ((LINK->LINK->pageline >= pagelength) & (!BUFEOF(inst.f))) {
	  fprintf(listing.f, "\f");
	  pageheader(LINK->LINK);
	}
	if (!BUFEOF(inst.f))
	  startlistingline(LINK->LINK);
	LINK->LINK->lineposition = 0;
      } while (!(BUFEOF(inst.f) | (!P_eoln(inst.f))));
    }
  }
  if (BUFEOF(inst.f)) {
    if (LINK->LINK->quote)
      error(12L, LINK->LINK);
    if (!LINK->LINK->eoinst)
      error(13L, LINK->LINK);
    LINK->LINK->eoinst = true;   /* there are no more instructions */
    if (LINK->LINK->pass == 2)
      writelineinformation(LINK->LINK);
    writeerrors(LINK->LINK);
  } else {
    LINK->LINK->chr = getc(inst.f);
    if (LINK->LINK->chr == '\n')
      LINK->LINK->chr = ' ';
    LINK->LINK->lineposition++;
    /*if debugging then writeln(debug,'ichread',lineposition:3,chr); */
    putc(LINK->LINK->chr, listing.f);
  }

  /* check that the character is a normal ASCII and not
     a control character.  This will block tab characters. */
  /*
|  0 NUL|  1 SOH|  2 STX|  3 ETX|  4 EOT|  5 ENQ|  6 ACK|  7 BEL
|  8 BS |  9 HT | 10 NL | 11 VT | 12 NP | 13 CR | 14 SO | 15 SI
| 16 DLE| 17 DC1| 18 DC2| 19 DC3| 20 DC4| 21 NAK| 22 SYN| 23 ETB
| 24 CAN| 25 EM | 26 SUB| 27 ESC| 28 FS | 29 GS | 30 RS | 31 US
| 32 SP | 33  ! | 34  " | 35  # | 36  $ | 37  % | 38  & | 39  '
| 40  ( | 41  ) | 42  * | 43  + | 44  , | 45  - | 46  . | 47  /
| 48  0 | 49  1 | 50  2 | 51  3 | 52  4 | 53  5 | 54  6 | 55  7
| 56  8 | 57  9 | 58  : | 59  ; | 60  < | 61  = | 62  > | 63  ?
| 64  @ | 65  A | 66  B | 67  C | 68  D | 69  E | 70  F | 71  G
| 72  H | 73  I | 74  J | 75  K | 76  L | 77  M | 78  N | 79  O
| 80  P | 81  Q | 82  R | 83  S | 84  T | 85  U | 86  V | 87  W
| 88  X | 89  Y | 90  Z | 91  [ | 92  \ | 93  ] | 94  ^ | 95  _
| 96  ` | 97  a | 98  b | 99  c |100  d |101  e |102  f |103  g
|104  h |105  i |106  j |107  k |108  l |109  m |110  n |111  o
|112  p |113  q |114  r |115  s |116  t |117  u |118  v |119  w
|120  x |121  y |122  z |123  { |124  | |125  } |126  ~ |127 DEL
*/
  if (LINK->LINK->chr < 32 || LINK->LINK->chr > 126) {
    printf("bad character found in inst file\n");
    error(33L, LINK->LINK);
  }

}

/* Local variables for findword: */
struct LOC_findword {
  struct LOC_readinstruction *LINK;
} ;

/* Local variables for findnonblank: */
struct LOC_findnonblank {
  struct LOC_findword *LINK;
} ;

Local Void skipblanks(LINK)
struct LOC_findnonblank *LINK;
{
  /* skip blank characters */
  while ((LINK->LINK->LINK->LINK->chr == ' ') & (!BUFEOF(inst.f))) {
    /* now at a non-blank character or end of the file */
    ichread(LINK->LINK->LINK);
  }
}

Local Void findnonblank(LINK)
struct LOC_findword *LINK;
{
  /* find the next non blank character, skipping up to one comment */
  struct LOC_findnonblank V;

  V.LINK = LINK;
  skipblanks(&V);
  if (BUFEOF(inst.f))
    return;
  if (LINK->LINK->LINK->chr == '(') {
    LINK->LINK->LINK->parentheses++;
    ichread(LINK->LINK);
    if (LINK->LINK->LINK->chr != '*')  /* a comment */
      return;
    LINK->LINK->LINK->commentline = LINK->LINK->LINK->linecount;
    LINK->LINK->LINK->comment = true;
    while ((LINK->LINK->LINK->chr != ')') & (!BUFEOF(inst.f))) {
      while ((LINK->LINK->LINK->chr != '*') & (!BUFEOF(inst.f)))
	ichread(LINK->LINK);
      if (BUFEOF(inst.f))
	error(10L, LINK->LINK->LINK);
      else
	ichread(LINK->LINK);
    }
    /* get past the } */
    LINK->LINK->LINK->comment = false;
    if (!BUFEOF(inst.f))   /* get past the ) */
      ichread(LINK->LINK);
    LINK->LINK->LINK->parentheses--;
    return;
  }
  if (LINK->LINK->LINK->chr == '{') {   /* new comment type */
    LINK->LINK->LINK->commentline = LINK->LINK->LINK->linecount;
    while ((LINK->LINK->LINK->chr != '}') & (!BUFEOF(inst.f)))
      ichread(LINK->LINK);
    if (BUFEOF(inst.f))
      error(10L, LINK->LINK->LINK);
    else
      ichread(LINK->LINK);
    return;
  }
  /* get past the } */
  if (LINK->LINK->LINK->chr == ')') {
    LINK->LINK->LINK->parentheses--;
    ichread(LINK->LINK);   /* get a move on.. */
    skipblanks(&V);
    return;
  }
  if (LINK->LINK->LINK->chr == ';') {
    LINK->LINK->LINK->eoinst = true;   /* get past the ; */
    ichread(LINK->LINK);
  } else if (LINK->LINK->LINK->chr != ' ')
    LINK->LINK->LINK->significant = true;
}

Local Void findword(LINK)
struct LOC_readinstruction *LINK;
{
  /* find the next significant item, nonblank, noncomment */
  struct LOC_findword V;

  V.LINK = LINK;
  LINK->LINK->significant = false;
  /* keep trying to find a significant non blank */
  while ((!LINK->LINK->significant) & (!BUFEOF(inst.f)))
    findnonblank(&V);
}

Local Void showparsed(debug, parsedword, parsedlength, parsedlocation, LINK)
_TEXT *debug;
Char *parsedword;
long parsedlength, parsedlocation;
struct LOC_readinstruction *LINK;
{
  /* the latest word parsed from the instructions */
  /* the length of parsedword */
  /* current location in parsedword */
  /* show the parsed word */
  long index;   /* index to parsed word */

  fprintf(debug->f, "parsedword: \"");
  for (index = 0; index < parsedlength; index++)
    putc(parsedword[index], debug->f);
  fprintf(debug->f, "\" <- parsedlength = %ld\n", parsedlength);
  fprintf(debug->f, "             ");
  for (index = 1; index < parsedlocation; index++)
    putc(' ', debug->f);
  fprintf(debug->f, "^ parsedlocation = %ld\n", parsedlocation);
}

Local Void parse(anumber, LINK)
boolean anumber;
struct LOC_readinstruction *LINK;
{
  /* parse out a new word, the result is in parsedword
the parser assumes that the first character of the word is in chr.
If anumber is true then stop parsing when the next character is not a
number */
  long j;   /* index to clear the remainder of parsedword */
  boolean stopcharacter;   /* characters to stop the parse */
  boolean stopcondition;   /* condition to stop the parse */

  for (LINK->LINK->parsedlength = 1;
       LINK->LINK->parsedlength <= widinst;
       LINK->LINK->parsedlength++)
    LINK->LINK->parsedword[LINK->LINK->parsedlength-1] = ' ';
  LINK->LINK->parsedlength = 1;
  LINK->LINK->parsedword[LINK->LINK->parsedlength-1] = LINK->LINK->chr;

  /*zzzfff*/
  /*
if eoln(inst) then writeln(output,'parse: eoln');
writeln(output,'in parse: parsedword[',parsedlength:1,']=', parsedword[parsedlength]);
*/
  if (!P_eoln(inst.f)) {
    do {   /* record up to space, ';', end of line or end of file */
      LINK->LINK->correct = true;
      if (LINK->LINK->parsedlength >= widinst)
	error(9L, LINK->LINK);
      if (LINK->LINK->correct) {
	ichread(LINK);
	/*
2000 Oct 17: the linebreak prevented correct parsing
if the ";" was on the line following the with.
That is, for:

get from 4021131 -50 to same +30 direction +
	 with a4021131c
;

the 'c' was lost.

	            if not eof(inst) and not linebreak then begin
	*/
	if (!BUFEOF(inst.f)) {
	  LINK->LINK->parsedlength++;
	  LINK->LINK->parsedword[LINK->LINK->parsedlength-1] = LINK->LINK->chr;
	  /*
; writeln(output,'parse chr = ',chr);
*/
	}
      }

      stopcharacter = (LINK->LINK->chr == ';' || LINK->LINK->chr == ')' ||
		       LINK->LINK->chr == '(' || LINK->LINK->chr == ' ') |
		      (!P_inset(LINK->LINK->chr, LINK->LINK->numbers) &&
		       LINK->LINK->chr != '-' && LINK->LINK->chr != '+' &&
		       LINK->LINK->chr != '.' && anumber);
      stopcondition = ((LINK->LINK->linebreak | BUFEOF(inst.f)) ||
		       !LINK->LINK->correct);
    } while (!(stopcharacter || stopcondition));

    if (stopcharacter)
      LINK->LINK->parsedlength--;

    /* bump parentheses */
    if (LINK->LINK->chr == ')' || LINK->LINK->chr == '(') {
      switch (LINK->LINK->chr) {   /* get past the parentheses */

      case '(':
	LINK->LINK->parentheses++;
	break;

      case ')':
	LINK->LINK->parentheses--;
	break;
      }
      ichread(LINK);
    }
    if (LINK->LINK->parsedlength < widinst)
    {   /* clear the rest of parsedword */
      for (j = LINK->LINK->parsedlength; j < widinst; j++)
	LINK->LINK->parsedword[j] = ' ';
    }
    LINK->LINK->eoinst = (LINK->LINK->chr == ';') | BUFEOF(inst.f);
  }

  else {
    ichread(LINK);
    /* Step onwards ... to avoid an infinite loop!
       2000 Oct 17:  This avoids a problem if there is a carriage return
       immediately after 'direction +'.  */
    /*zzzfff */
  }
  /*
showparsed(output, parsedword, parsedlength, parsedlocation);
*/
  if (debugging)
    showparsed(&debug, LINK->LINK->parsedword, LINK->LINK->parsedlength,
	       LINK->LINK->parsedlocation, LINK);
  /*
if debugging then writeln(debug,'parse: "',parsedword:parsedlength,'"');
if debugging then writeln(listing,'parse: "',parsedword:parsedlength,'"');
*/
  /*
writeln(output,'out parse: parsedword[',parsedlength:1,']=', parsedword[parsedlength]);
*/
}

Local Void geteoinst(LINK)
struct LOC_readinstruction *LINK;
{
  /* get to end of instruction */
  /* this routine is used by all ir routines to find the end
     of the current instruction, especially if that routine failed.
     also it sets eoinst to true. note: it does nothing if chr=';'.  */
  boolean previouscorrect;

  if (debugging)
    fprintf(debug.f, "geteoinst\n");
  previouscorrect = LINK->LINK->correct;
  while ((!LINK->LINK->eoinst) & (!BUFEOF(inst.f))) {
    findword(LINK);
    if (!LINK->LINK->eoinst) {
      if (!BUFEOF(inst.f))
	parse(false, LINK);
    }
  }
  /* since parse result is usually correct, we set: */
  LINK->LINK->correct = (LINK->LINK->correct && previouscorrect);
}

/* notes on all ir routines: to get to the first character to read,
   a findword must be done first.  this finds the first 'significant'
   character of the word: non-parsing characters (see procedure
   parse).  errors cause a call to geteoinst.  they must use the routine
   ichread to read in characters from the delila file (inst). */

Local Void irquote(aline, LINK)
line **aline;
struct LOC_readinstruction *LINK;
{
  /* read in a quote into several lines */
  /* both single and double quotes are recognized */
  line *workline, *nextline;
  Char aquote;   /* the quote character recognized */

  LINK->LINK->correct = true;
  findword(LINK);
  if (!LINK->LINK->correct)
    return;
  workline = *aline;   /* point to previous first line */
  if (workline != NULL) {  /* find last line */
    while (workline->next != NULL) {
      if (workline == workline->next) {
	printf("PROGRAM ERROR: An infinite end loop was found in irquote\n");
	workline->next = NULL;
      } else
	workline = workline->next;
    }
    getline(&nextline);   /* grab new line */
    workline->next = nextline;   /* string it in */
    workline = nextline;   /* move pointer */
  } else {   /* make aline know about this */
    getline(&workline);   /* make line */
    *aline = workline;
  }
  aquote = LINK->LINK->chr;
  if (LINK->LINK->chr != '"' && LINK->LINK->chr != '\'') {
    error(16L, LINK->LINK);
    geteoinst(LINK);
    return;
  }
  LINK->LINK->quote = true;
  ichread(LINK);
  while (LINK->LINK->chr != aquote && LINK->LINK->correct) {
    if (workline->length == linelength || LINK->LINK->linebreak) {
      getline(&nextline);
      workline->next = nextline;
      workline = nextline;
    }
    workline->length++;
    workline->letters[workline->length - 1] = LINK->LINK->chr;
    ichread(LINK);
  }
  LINK->LINK->quote = false;
  if (LINK->LINK->correct)   /* get past the quote */
    ichread(LINK);
}

Local Void irtitle(LINK)
struct LOC_readinstruction *LINK;
{
  /* get the book title from the instructions */
  line *extra;

  /*if debugging then writeln(debug,'irtitle');*/
  irquote(&LINK->LINK->title, LINK);
  if (!LINK->LINK->correct)
    return;
  /* now remove extra title: */
  extra = LINK->LINK->title->next;
  while (extra != NULL)
    clearline(&extra);
  LINK->LINK->title->next = NULL;
}

Local Void irlongname(LINK)
struct LOC_readinstruction *LINK;
{
  /* get the book longname from the instructions */
  line *extra;
  _TEXT TEMP;

  /*if debugging then writeln(debug,'irlongname');*/
  /* clear away any previous junk */
  clearline(&longname);
  irquote(&longname, LINK);
  if (LINK->LINK->correct)
    longnameexists = true;
  else
    longnameexists = false;
  /* clear any extra lines */
  extra = longname->next;
  if (extra == NULL)
    return;
  printf("WARNING: the extra letters of this long name are being ignored:\n");
  putchar('"');
  TEMP.f = stdout;
  *TEMP.name = '\0';
  writeline(&TEMP, longname, false);
  printf("\"\n");
  printf("The extra letters are: \n");
  putchar('"');
  TEMP.f = stdout;
  *TEMP.name = '\0';
  writeline(&TEMP, extra, false);
  printf("\"\n");
  emptyline(&extra);
  longname->next = NULL;
}

Local Void irword(LINK)
struct LOC_readinstruction *LINK;
{
  /* this routine reads and translates an instruction word into
     the delila word called 'word'.
     it sets correct to true if the read was successful,
     otherwise sets it to false */
  boolean matching;   /* have we identified the parsed word? */
  long i;   /* index for parsedword and wordlist */

  /*if debugging then writeln(debug,'irword');*/
  findword(LINK);
  if (LINK->LINK->eoinst) {
    error(15L, LINK->LINK);
    return;
  }
  parse(false, LINK);   /* result is in parsedword */
  if (LINK->LINK->correct) {
    matching = false;
    LINK->LINK->word = alldelila;   /* start at first delilaword */

    /* now identify the parsed word in wordlist: */
    while (!matching && (int)LINK->LINK->word < (int)eodelila)
    {   /* scan for the worddelila */
      /*if debugging then writeln(debug,'ird1',ord(word):5);
if debugging then writeln(debug,wordlist[word]);
*/
      matching = true;
      i = 0;
      while (LINK->LINK->parsedword[i] != ' ' && matching && i < widinst - 1)
      {   /* scan this worddelila */
	i++;
	/*if debugging then writeln(debug,'ird4',i:5,parsedword);
*/
	matching = (LINK->LINK->parsedword[i-1] ==
		    LINK->LINK->wordlist[(long)LINK->LINK->word][i-1]);
      }
      if (matching) {
	if (i <= minword) {
	  if (LINK->LINK->wordlist[(long)LINK->LINK->word][i] != ' ')
	    matching = false;
	}
      }
      if (!matching)
	LINK->LINK->word = (delilaword)((long)LINK->LINK->word + 1);
    }
    LINK->LINK->correct = matching;
  }
  if (LINK->LINK->correct)
    return;
  /* the end of the word is (probably) before this point */
  LINK->LINK->lineposition--;
  error(2L, LINK->LINK);
  LINK->LINK->lineposition++;
  geteoinst(LINK);
}

Local Void irkeyname(LINK)
struct LOC_readinstruction *LINK;
{
  /* read a key name into the variable keyname.
     left justified, blanks trailing. */
  long i;

  if (LINK->LINK->eoinst) {
    error(15L, LINK->LINK);
    return;
  }
  findword(LINK);
  parse(false, LINK);
  if (!LINK->LINK->correct)
    return;
  LINK->LINK->keyname.length = 0;
  /* stuff the parsed word into the key name */
  for (i = 0; i < namelength; i++) {
    LINK->LINK->keyname.letters[i] = LINK->LINK->parsedword[i];
    if (LINK->LINK->parsedword[i] != ' ')
      LINK->LINK->keyname.length++;
  }
  if (LINK->LINK->keyname.length < widinst)
    LINK->LINK->correct = (LINK->LINK->parsedword[LINK->LINK->keyname.length] ==
			   ' ');
  else
    LINK->LINK->correct = true;
  /* since widinst>=namelength */
  if (!LINK->LINK->correct) {
    error(14L, LINK->LINK);
    geteoinst(LINK);
  }
  /*;if debugging then writeln(debug,'keyname number',letters,'number');*/
}

/* Local variables for irnumber: */
struct LOC_irnumber {
  struct LOC_readinstruction *LINK;
  long i;   /* index to parsedword */
  long start;   /* reading the number from place in parsedword */
  long increment;   /* to inumber */
} ;

Local Void digitize(LINK)
struct LOC_irnumber *LINK;
{
  /* convert a characte to a digit */
  switch (LINK->LINK->LINK->parsedword[LINK->i-1]) {

  case '0':
    LINK->increment = 0;
    break;

  case '1':
    LINK->increment = 1;
    break;

  case '2':
    LINK->increment = 2;
    break;

  case '3':
    LINK->increment = 3;
    break;

  case '4':
    LINK->increment = 4;
    break;

  case '5':
    LINK->increment = 5;
    break;

  case '6':
    LINK->increment = 6;
    break;

  case '7':
    LINK->increment = 7;
    break;

  case '8':
    LINK->increment = 8;
    break;

  case '9':
    LINK->increment = 9;
    break;
  }
}

Local Void signblank(LINK)
struct LOC_irnumber *LINK;
{
  /* allow blanks after the sign */
  if (LINK->LINK->LINK->parsedword[LINK->i] != ' ')
    return;
  findword(LINK->LINK);
  parse(true, LINK->LINK);
  LINK->start = 1;
}

Local Void irnumber(LINK)
struct LOC_readinstruction *LINK;
{
  /* read an integer and put it in the global inumber.
If the number has a decimal place, the truncated version is returned
in inumber and the complete number is returned in rnumber.
     check that the number has proper format. */
  struct LOC_irnumber V;
  long sign;   /* of the number */
  long stop;   /* to */
  long power;   /* powers of 10 for this number */
  boolean areal = false;   /* a real number was encountered */
  long FORLIM;

  V.LINK = LINK;
  LINK->LINK->inumber = -LONG_MAX;   /* flag for reading error */
  if (LINK->LINK->eoinst) {
    /*
;writeln(output,'inumber=', inumber:1);
*/
    error(15L, LINK->LINK);
    return;
  }
  findword(LINK);
  parse(true, LINK);
  if (LINK->LINK->correct) {
    V.i = 1;
    if (LINK->LINK->parsedword[V.i-1] == '+') {
      sign = 1;
      V.start = 2;
      signblank(&V);
    } else if (LINK->LINK->parsedword[V.i-1] == '-') {
      sign = -1;
      V.start = 2;
      signblank(&V);
    } else {
      sign = 1;
      V.start = 1;
    }
    V.i = V.start;
    LINK->LINK->correct = true;
    while (V.i < widinst && LINK->LINK->parsedword[V.i-1] != ' ' &&
	   LINK->LINK->correct && !areal) {
      if (LINK->LINK->parsedword[V.i-1] == '.')
	areal = true;
      LINK->LINK->correct = (P_inset(LINK->LINK->parsedword[V.i-1],
				     LINK->LINK->numbers) || areal);
      if (!areal)
	V.i++;
    }

    if (LINK->LINK->correct) {  /* build that number.. */
      stop = V.i - 1;   /* parsedword[i] is blank */
      power = 1;   /* start at one"s place */
      LINK->LINK->inumber = 0;   /* start sum at zero */
      FORLIM = V.start;
      for (V.i = stop; V.i >= FORLIM; V.i--) {
	digitize(&V);
	LINK->LINK->inumber += power * V.increment;
	power *= 10;
      }
      LINK->LINK->inumber *= sign;

      LINK->LINK->rnumber = LINK->LINK->inumber;
      if (areal) {
	V.start = stop + 2;
	power = 10;   /* start at tens place */
	V.i = V.start;
	while (LINK->LINK->parsedword[V.i-1] != ' ') {
	  digitize(&V);
	  /*
writeln(output,'parsedword[',i,']=', parsedword[i]);
writeln(output,'increment=', increment:1);
writeln(output,'rnumber=', rnumber:10:5);
*/
	  LINK->LINK->rnumber += (double)V.increment / power;
	  power *= 10;
	  V.i++;
	}
      }

      if (areal)
	rvalueposition(LINK->LINK->rnumber, LINK->LINK);
      else
	ivalueposition(LINK->LINK->inumber, LINK->LINK);
    }
  }
  if (!LINK->LINK->correct) {
    error(4L, LINK->LINK);
    geteoinst(LINK);
  }
}

/* ************ MUTATION PROCEDURES ***************************************/
/* To allow these routines to skip to the end of the instruction,
they must be below geteoinst */

/* begin module delila.readchangeset */
/* routines for handling mutations:  changeset */

Local Void mutationparseerror(e, LINK)
long e;
struct LOC_readinstruction *LINK;
{
  /* show the error at the correct location on the previously
parsed word */
  long shift;

  /* how much to shift the recording line position
     to account for the position of the error in the parsedword */
  /*EEE*/
  shift = LINK->LINK->parsedlength - LINK->LINK->parsedlocation + 1;
  /*
showparsed;
writeln(output,'mutationparseerror: shift = ',shift:1);
*/
  LINK->LINK->lineposition -= shift;
  error(e, LINK->LINK);
  LINK->LINK->lineposition += shift;
}

Local Void grabcharacter(c_, done, LINK)
Char *c_;
boolean *done;
struct LOC_readinstruction *LINK;
{
  /* Get the next character in parsedword */
  /*
writeln(output,'grabcharacter ---------');
*/
  if (LINK->LINK->parsedlocation >= LINK->LINK->parsedlength) {
    *done = true;
    *c_ = ' ';
    return;
  }
  LINK->LINK->parsedlocation++;
  *c_ = LINK->LINK->parsedword[LINK->LINK->parsedlocation-1];
  *done = false;
  /*
else begin
writeln(output,'refused grabcharacter, correct = ',correct);
end;
*/
  /*
;showparsed;
     writeln(output,'grabcharacter: parsedlocation = ',parsedlocation:1);
     writeln(output,'grabcharacter: ',c:1);
     writeln(output,'grabcharacter: correct = ',correct);
  */
}

/* Local variables for grabnumber: */
struct LOC_grabnumber {
  struct LOC_readinstruction *LINK;
  boolean *correct;
  long digits;   /* number of digits obtained */
  long signnumber;   /* Number of signs for this number */
} ;

Local Void signstuff(LINK)
struct LOC_grabnumber *LINK;
{
  /* handle stuff for + for - signs */
  if (LINK->digits > 0) {
    mutationparseerror(31L, LINK->LINK);
    printf("Numbers cannot have more than 1 sign (+ or -).\n");
    *LINK->correct = false;
  }
  LINK->signnumber++;
}

Local Void grabnumber(number, donereading, correct_, LINK)
long *number;
boolean *donereading, *correct_;
struct LOC_readinstruction *LINK;
{
  /* get the next number in parsedword.  This can't be done
by the regular Delila routines because it is imbedded in the middle
of the parsed word.  If we are at the end of the parse string,
done is true.  If the number is correct, correct is true. */
  struct LOC_grabnumber V;
  long digit;   /* a digit in the number */
  boolean donenumber = false;
  /* done reading the number.  This is different
     from being done reading the parsed string. */
  long sign = 1;   /* +1 is positive, -1 is negative */

  V.LINK = LINK;
  V.correct = correct_;
  /*
debugging := true;
;writeln(output,'grabnumber BEGIN DDD correct =',correct);
*/
  if (!*V.correct)
    return;
  /*
;showparsed;
;  writeln(output,'grabnumber: number = ',round(number):1);
;writeln(output,'grabnumber END DDD correct =',correct);
;debugging := false;
*/
  *number = 0;
  V.digits = 0;
  V.signnumber = 0;
  while (!donenumber) {
    grabcharacter(&mutischar, donereading, LINK);
    if (*donereading)
      donenumber = true;
    /*zzz deal with 1-54*/
    if (donenumber)
      break;
    if (P_inset(mutischar, LINK->LINK->numbers)) {
      digit = mutischar - '0';
      V.digits++;
      *number = *number * 10 + digit;
      /* writeln(output,'digit = ',digit:1); writeln(output,'digits = ',digits:1); */
      continue;
    }
    if (mutischar == '-') {
      sign = -1;
      signstuff(&V);
      continue;
    }
    if (mutischar == '+') {
      sign = 1;
      signstuff(&V);
    } else {
      /* the last location parsed is one base earlier */
      LINK->LINK->parsedlocation--;
      donenumber = true;
      /*DDD*/
    }
  }
  if (V.digits == 0) {
    mutationparseerror(26L, LINK);
    *V.correct = false;
  }
  if (V.signnumber > 1) {
    /*EEE*/
    mutationparseerror(31L, LINK);
    *V.correct = false;
  }
  if (sign < 0)
    *number = -*number;
}

Local Void readchanges(c_, done, LINK)
changeset *c_;
boolean *done;
struct LOC_readinstruction *LINK;
{
  /* Read the base changes from f in the form 'g2343c'.
    If there is an error in reading, set correct to false. */
  changedata *WITH;

  /*
writeln(output,'BEGIN readchanges ===========================');
*/
  WITH = &c_->data[c_->number - 1];
  /*
writeln(output,'baseold = ',baseold);
writeln(output,'basenew = ',basenew);
writeln(output,'basecoo1 = ',basecoo1:1);
writeln(output,'correct: ',correct);
writeln(output,'END readchanges ===========================');
*/
  WITH->changetype = 'c';
  /*
        nextnonblank(f);
        read(f, baseold);
        nextnonblank(f);
        read(f, basecoo1);
  */
  grabcharacter(&WITH->baseold, done, LINK);
  if (WITH->baseold != 't' && WITH->baseold != 'g' && WITH->baseold != 'c' &&
      WITH->baseold != 'a') {
    printf("ERROR: old base usually should be a, c, g, t\n");
    mutationparseerror(20L, LINK);
  }
  grabnumber(&WITH->basecoo1, done, &LINK->LINK->correct, LINK);
  /*
writeln(output,'basecoo1 = ',basecoo1:1);
*/
  if (!LINK->LINK->correct)
    return;
  WITH->basecoo2 = WITH->basecoo1;
  grabcharacter(&WITH->basenew, done, LINK);
  /*zzzfff*/
  /*
if done then begin
   writeln(output,'zzzzfff');
end;
  */
  if (WITH->basenew != 't' && WITH->basenew != 'g' && WITH->basenew != 'c' &&
      WITH->basenew != 'a') {
    printf("ERROR: new base should be a, c, g, or t\n");
    mutischar = WITH->basenew;
    mutationparseerror(21L, LINK);
  }
  WITH->inserts = 0;
}

Local Void checknumberorder(basecoo1, basecoo2, LINK)
double basecoo1, basecoo2;
struct LOC_readinstruction *LINK;
{
  /* Make sure that the value of basecoo1 is lessthan or equal to
basecoo2, following the Libdef */
  if (basecoo1 > basecoo2) {
    error(27L, LINK->LINK);
    /*EEE*/
    LINK->LINK->correct = false;
  }
}

Local Void readinsertion(c_, done, LINK)
changeset *c_;
boolean *done;
struct LOC_readinstruction *LINK;
{
  /* Read the insertion from f in the form 'i449,450tt'. */
  boolean doneinsert = false;   /* true if we are done with the insert */
  changedata *WITH;

  /*
writeln(output,'readinsertion ==================================');
*/
  WITH = &c_->data[c_->number - 1];
  /*
        read(f, changetype);
        read(f, basecoo1);
        skipblanks(f);
        read(f, comma);
        read(f, basecoo2);
  */
  grabcharacter(&WITH->changetype, done, LINK);
  if (*done)
    LINK->LINK->correct = false;
  if (!LINK->LINK->correct)
    return;
  grabnumber(&WITH->basecoo1, done, &LINK->LINK->correct, LINK);
  if (*done)
    LINK->LINK->correct = false;
  if (!LINK->LINK->correct)
    return;
  grabcharacter(&mutischar, done, LINK);
  if (*done)
    LINK->LINK->correct = false;
  if (mutischar != ',') {
    printf(" comma expected between coordinates for insertion\n");
    mutationparseerror(25L, LINK);
  }
  if (!LINK->LINK->correct)
    return;
  grabnumber(&WITH->basecoo2, done, &LINK->LINK->correct, LINK);
  if (LINK->LINK->correct)
    checknumberorder((double)WITH->basecoo1, (double)WITH->basecoo2, LINK);
  if (!LINK->LINK->correct)
    return;
  WITH->inserts = 0;
  WITH->insertcomplement = false;
  do {
    grabcharacter(&mutischar, done, LINK);
    /*
showparsed;
*/
    if (!*done) {
      /*
writeln(output,'readinsertion 1');
writeln(output,'inserts =',inserts:1,' mutischar = "',mutischar,'"');
*/
      if (mutischar == '.')
	doneinsert = true;
      else if (mutischar == '~') {
	if (WITH->inserts != 0) {
	  doneinsert = true;
	  LINK->LINK->correct = false;
	  mutationparseerror(32L, LINK);
	  /*zzz111*/
	} else
	  WITH->insertcomplement = true;
      } else if (mutischar == 't' || mutischar == 'g' || mutischar == 'c' ||
		 mutischar == 'a') {
	WITH->inserts++;
	/*
writeln(output,'readinsertion 2');
writeln(output,'inserts =',inserts:1,' mutischar = "',mutischar,'"');
showparsed;
*/
	WITH->insert[WITH->inserts - 1] = mutischar;
	if (WITH->inserts > insertmax) {
	  printf(
	    " no more than %ld insertion bases allowed, increase constant insertmax\n",
	    (long)insertmax);
	  mutationparseerror(24L, LINK);
	  doneinsert = true;
	  LINK->LINK->correct = false;
	}
      } else {
	doneinsert = true;
	LINK->LINK->correct = false;
	mutationparseerror(22L, LINK);
	/* bad character detected */
	/*zzz111*/
      }
      if (LINK->LINK->parsedlocation >= LINK->LINK->parsedlength)
	doneinsert = true;
    } else
      doneinsert = true;
  } while (!doneinsert);
}

Local Void readdeletion(c_, done, LINK)
changeset *c_;
boolean *done;
struct LOC_readinstruction *LINK;
{
  /* Read the deletion from parsedword in the form 'M55114 d449,450'. */
  changedata *WITH;

  /*
writeln(output,'readdeletion');
*/
  WITH = &c_->data[c_->number - 1];
  /*
;writeln(output,'readdeletion END DDD correct =',correct);
*/
  /*
        read(f, changetype);
        read(f, basecoo1);
        skipblanks(f);
        read(f, comma);
        read(f, basecoo2);
;writeln(output,'readdeletion BEGIN DDD correct =',correct);
  */
  WITH->inserts = 0;
  grabcharacter(&WITH->changetype, done, LINK);
  if (!LINK->LINK->correct)
    return;
  grabnumber(&WITH->basecoo1, done, &LINK->LINK->correct, LINK);
  if (!LINK->LINK->correct)
    return;
  grabcharacter(&mutischar, done, LINK);
  if (!LINK->LINK->correct)
    return;
  if (mutischar != ',') {
    printf("comma expected between coordinates for deletion\n");
    mutationparseerror(23L, LINK);
    *done = true;
    LINK->LINK->correct = false;
  }
  /*
;writeln(output,'readdeletion MID 1 DDD correct =',correct);
*/
  if (LINK->LINK->correct)
    grabnumber(&WITH->basecoo2, done, &LINK->LINK->correct, LINK);
  /*
;writeln(output,'readdeletion MID 2 DDD correct =',correct);
*/
  if (LINK->LINK->correct)
    checknumberorder((double)WITH->basecoo1, (double)WITH->basecoo2, LINK);
}

Local Void readchangeset(c_, LINK)
changeset *c_;
struct LOC_readinstruction *LINK;
{
  /* read in the changes for a sequence.  */
  boolean done = false;
      /* we found the end of the statement so we are done */
  boolean dotfound = false;   /* we have found a separation dot */
  Char lastcharacter;   /* have we found a dot at the end? */

  /*
writeln(output,'readchangeset');
*/
  c_->number = 0;
  findword(LINK);
  parse(false, LINK);

  if (!LINK->LINK->correct)
    return;
  /*
writechangeset(output,c);
;writeln(output,'END OF  READCHANGESET --------------------------------------------');
*/
  /* make sure there is no initial dot */
  LINK->LINK->parsedlocation = 0;   /* about to read */
  grabcharacter(&mutischar, &done, LINK);
  if (mutischar == '.') {
    printf("Extra dots not allowed\n");
    mutationparseerror(29L, LINK);
    LINK->LINK->correct = false;
  }

  /* start main reading loop */
  LINK->LINK->parsedlocation = 0;   /* about to read */

  while (!done) {
    if (!LINK->LINK->correct)
      continue;

    /*
writeln(output,'LOOP in READCHANGESET --------------------------------------------');
*/
    /*EEE*/
    grabcharacter(&mutischar, &done, LINK);
    if (!done) {
      if (mutischar == '.') {
	if (dotfound) {
	  printf("Extra dots not allowed\n");
	  mutationparseerror(29L, LINK);
	  done = true;
	} else
	  dotfound = true;
      } else if (mutischar == 'i' || mutischar == 'd' || mutischar == 't' ||
		 mutischar == 'g' || mutischar == 'c' || mutischar == 'a') {
	c_->number++;
	if (c_->number > changesetmax) {
	  printf("Too many changes requested, increase constant changesetmax.");
	  mutationparseerror(28L, LINK);
	  LINK->LINK->correct = false;
	  done = true;
	}
	if (LINK->LINK->correct) {
	  dotfound = false;
	  LINK->LINK->parsedlocation--;
	  /*
writeln(marksdelila,'* LOOP in READCHANGESET ----- number = ',
	                       number:1,'-----------------');
	  */
	  switch (mutischar) {

	  case 'a':
	  case 'c':
	  case 'g':
	  case 't':
	    readchanges(c_, &done, LINK);
	    break;

	  case 'd':
	    readdeletion(c_, &done, LINK);
	    break;

	  case 'i':
	    readinsertion(c_, &done, LINK);
	    break;
	  }
	}
      } else {
	printf("Unidentified change command:");
	printf(" \"%c\"\n", mutischar);
	mutationparseerror(30L, LINK);
	done = true;
	LINK->LINK->correct = false;
      }
      lastcharacter = mutischar;
    }
    if (!LINK->LINK->correct)
      done = true;
  }
  if (lastcharacter == '.') {  /* no dots at the end either */
    printf("Extra dots not allowed\n");
    mutationparseerror(29L, LINK);
  }
}

/* Local variables for sortchanges: */
struct LOC_sortchanges {
  struct LOC_readinstruction *LINK;
  changeset *sorted;
  Char phenotype;
} ;

/* Local variables for lessthan: */
struct LOC_lessthan {
  struct LOC_sortchanges *LINK;
} ;

Local long adjust(x, LINK)
long x;
struct LOC_lessthan *LINK;
{
  /* Sorting does NOT use the ends of an insert, but rather the middle bases.
     This allows g1t.i1,4cc to be properly sorted with the g1t in front.
     Sorting is sufficiently rare that we'll just compute this here. */
  long xposition;   /* adjusted locations of x */
  changedata *WITH;

  xposition = LINK->LINK->sorted->data[x-1].internal1;
  if (LINK->LINK->sorted->data[x-1].changetype != 'i')
    return xposition;
  /*
     then xposition := xposition + 1;
  */
  WITH = &LINK->LINK->sorted->data[x-1];
  /**U WILD external unsorted: i1,2tct.i5,6ggg.d6,8.d1,1
*U WILD external sorted:   i1,2tct.d1,1.i5,6ggg.d6,8
should not have sorted, so
        if internal1 + 1 < internal2
  */
  if (WITH->internal1 + 1 <= WITH->internal2)
    xposition++;
  return xposition;
}  /* adjust */

Local boolean lessthan(a_, b, LINK)
long a_, b;
struct LOC_sortchanges *LINK;
{
  /* see quicksort */
  struct LOC_lessthan V;
  boolean Result;
  long aposition, bposition;   /* adjusted locations of a and b */
  Char atype, btype;   /* the types of a and b */

  V.LINK = LINK;
  /*SSS*/
  aposition = adjust(a_, &V);
  bposition = adjust(b, &V);

  if (aposition != bposition || a_ == b)
    return (aposition < bposition);
  atype = LINK->sorted->data[a_-1].changetype;
  btype = LINK->sorted->data[b-1].changetype;
  /*
Interesting chunk of code, but base changes can be next to insertions
and deletions too.
        (* this can only occur when insertions are right next to deletions *)
        if not( ((atype='i') and (btype='d')) or
                ((atype='d') and (btype='i'))   )
        then begin
           writeln(output,'sortchanges: DELILA SORTING ERROR');
           writeln(output,'Please contact toms@ncifcrf.gov!');
           write(output,'while sorting: ');
           wchangedata(output,sorted.data[a]);
           write(output,' and ');
           wchangedata(output,sorted.data[b]);
           writeln(output);
           write(output,'in: ');
           writechangeset(output,unsorted);
           writeln(output);
           write(output,'On the ');
           case phenotype of
              'w': write(output,'wild-type');
              'm': write(output,'mutant');
           end;
           writeln(output,'sequence.');
           writeln(output,'At position ',aposition:1,'=',bposition:1);
           crash
        end;
  */

  switch (LINK->phenotype) {

  /* the doubleY wins always */
  case 'w':  /* wild-type situation */
    if (atype == 'i')
      Result = true;
    else
      Result = false;
    break;

  case 'm':  /* mutant situation */
    if (atype == 'd')
      Result = true;
    else
      Result = false;
    break;
  }

  /* old:
     lessthan:=(sorted.data[a].internal1 < sorted.data[b].internal1)
  */

  return Result;
}  /* lessthan */

Local Void swap_(a_, b, LINK)
long a_, b;
struct LOC_sortchanges *LINK;
{
  /* see quicksort */
  changedata hold;

  hold = LINK->sorted->data[a_-1];
  LINK->sorted->data[a_-1] = LINK->sorted->data[b-1];
  LINK->sorted->data[b-1] = hold;
  /*;write(output,'a=',a:1,', b=',b:1); print (@ for testing */
}  /* swap */

/* begin module quicksort */
Local Void quicksort(left, right, LINK)
position left, right;
struct LOC_sortchanges *LINK;
{
  /* 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 */
  position lower = left;
  position upper;   /* the positions looked at currently */
  position center;   /* the rough center of the region being sorted */

  center = (left + right) / 2;
  upper = right;
  do {
    while (lessthan(lower, center, LINK))
      lower++;
    while (lessthan(center, upper, LINK))
      upper--;
    if (lower <= upper) {
      /* keep track of the center through the map: */
      if (lower == center)
	center = upper;
      else if (upper == center)
	center = lower;
      swap_(lower, upper, LINK);
      lower++;
      upper--;
    }
  } while (lower <= upper);
  if (left < upper)
    quicksort(left, upper, LINK);
  if (lower < right)
    quicksort(lower, right, LINK);
}

/* end module delila.readchangeset */
/* last common version:
dbmutate.readchangeset version = 1.89; (@ of dbmutate.p 1999 April 26 */

/* ************************************************************************ */
/* ************************************************************************ */
/* ************************************************************************ */

/* routines for marking the lister map */

/* begin module sortchanges */
Local Void sortchanges(unsorted, sorted_, phenotype_, LINK)
changeset unsorted, *sorted_;
Char phenotype_;
struct LOC_readinstruction *LINK;
{
  /* sort the changeset unsorted and put the result into sorted.  Since marks
need to be in increasing position order (as currently defined in lister) it
is nice to sort the changes for each piece.
* When phenotype = 'w', the sequence is considered wild-type.
In this case insertions are a single position and are listed BEFORE deletions,
since deletions will extend further to the 3'.
* When phenotype = 'm', the sequence is considered mutant.
In this case deletions are a single position and are listed BEFORE insertions,
since insertions will extend further to the 3'.
   */
  struct LOC_sortchanges V;

  /* end module quicksort version = 4.21; (@ of prgmod.p 1997 October 22 */
  V.LINK = LINK;
  V.sorted = sorted_;
  V.phenotype = phenotype_;
  *V.sorted = unsorted;
  quicksort(1L, V.sorted->number, &V);
}

/* Local variables for propagateonechange: */
struct LOC_propagateonechange {
  struct LOC_readinstruction *LINK;
  changeset *changes;
  long m, location;   /* location of a change */
  long shift;   /* amount to shift a change */
} ;

Local Void loop(LINK)
struct LOC_propagateonechange *LINK;
{
  /* propagate the change to all other all changes.  The second part
of the boolean test, for changes at internal+1 with inserts
is required for the case: get from 1 to 6 with i1,2tct.i1,3;  Without
it, the i1,3 doesn't get propagated past the i1,2tct. */
  long n;   /* counter for the changes, later places */
  long FORLIM;
  changedata *WITH;

  FORLIM = LINK->changes->number;
  /*writeln(output,'loop    : location = ',location:1);*/
  for (n = 0; n < FORLIM; n++) {
    /*write(output,'propagateonechange: TRY ');*/
    /*wchangedata(output,changes.data[n]);*/
    /*writeln(output);*/
    if (n + 1 != LINK->m) {
      if (LINK->location <= LINK->changes->data[n].internal1 ||
	  (LINK->location <= LINK->changes->data[n].internal1 + 1 &&
	   LINK->changes->data[n].changetype == 'i')) {
	WITH = &LINK->changes->data[n];
	/*write(output,'propagateonechange: shifting ');*/
	/*wchangedata(output,changes.data[n]);*/
	/*writeln(output);*/
	/*write  (output,'loop PRE: internal1 = ',internal1:1);*/
	/*writeln(output,         ' internal2 = ',internal2:1);*/
	WITH->internal1 += LINK->shift;
	WITH->internal2 += LINK->shift;
	/*write  (output,'loop POS: internal1 = ',internal1:1);*/
	/*writeln(output,         ' internal2 = ',internal2:1);*/
      }
    }
  }
}

/* end module sortchanges version = 1.89; (@ of dbmutate.p 1999 April 26 */

/* begin module propagateonechange */
Local Void propagateonechange(changes_, m_, pie, LINK)
changeset *changes_;
long m_;
piece *pie;
struct LOC_readinstruction *LINK;
{
  /* Propagate the one change at m through the rest of the changeset. */
  struct LOC_propagateonechange V;
  long b1, b2;
  /* internal coordinate values for the basecoo1 and
                      basecoo2 of the changeset */
  long deletes;   /* amount to delete the sequence */
  long pielength;   /* current length of the piece */
  changeset *WITH;
  changedata *WITH1;

  V.LINK = LINK;
  V.changes = changes_;
  V.m = m_;
  /*
writeln(output,'propagateonechange: m = ',m:1,' --------------------');
write(output,'propagateonechange: ');
wchangedata(output,changes.data[m]);
writeln(output);
*/
  WITH = V.changes;
  V.location = WITH->data[V.m-1].internal1;
  /* make location point to actual insertion start */
  /*write  (output,'changetype = data[',m:1,'] = ',data[m].changetype);*/
  /*writeln(output,' location = ',location:1);*/
  pielength = piecelength(pie);
  WITH1 = &WITH->data[V.m-1];
  b1 = WITH1->internal1;
  b2 = WITH1->internal2;
  switch (WITH1->changetype) {

  case 'c':   /* base changes cause no downstream changes */
    break;

  case 'i':
    V.location++;
    /* this code is from changesequence */
    if (b1 > pielength)
      b1 = pielength;
    if (b2 > pielength)
      b2 = pielength + 1;
    if (b1 < 0)
      b1 = 0;
    if (b2 < 1)   /* original */
      b2 = 1;
    deletes = b2 - b1 - 1;
    V.shift = WITH1->inserts - deletes;
    loop(&V);
    break;

  /* NOTE: i and d code are NOT identical and cannot be condensed! */
  case 'd':
    /* this code is from changesequence */
    if (b1 < 1)
      b1 = 1;
    if (b2 < 1)
      b2 = 1;
    if (b1 > pielength)
      b1 = pielength;
    if (b2 > pielength)
      b2 = pielength;
    V.shift = b2 - b1 + 1;
    V.shift = -V.shift;
    loop(&V);
    break;
  }
}

/* end module propagateonechange */

/* begin module delila.writemarks */

Local Void doubleYmark(markspots, internal1, internal2, pie, insertlowerbits,
		       insertupperbits, LINK)
_TEXT *markspots;
long internal1, internal2;
piece *pie;
double insertlowerbits, insertupperbits;
struct LOC_readinstruction *LINK;
{
  /* Put a doubleY mark between internal1 and internal 2 in file markspots for
piece pie.  The difference between these two coordinates must be 1,
and internal1 < internal2. */
  long b1;   /* adjusted coordinate for internal1 */
  long b2;   /* adjusted coordinate for internal2 */
  long shiftY;   /* amount in bases to shift the doubleY */

  fprintf(markspots->f, "* doubleY: internal1 = %ld\n", internal1);
  fprintf(markspots->f, "* doubleY: internal2 = %ld\n", internal2);
  if (internal2 - internal1 != 1) {
    printf("doubleY: program error: internal2-internal1 <> 1\n");
    crash();
  }

  if (withininternal(pie, internal2)) {
    /* If internal2 is inside the piece, then put the doubleY
       to the left of it. */
    b1 = internal2;
    b2 = internal2;
    shiftY = 0;
    fprintf(markspots->f, "* doubleY: case 1\n");
  } else {
    if (withininternal(pie, internal1)) {
      /* Ok, so internal 1 IS inside, so put the doubleY
         to the right of it by shifting 1 */
      b1 = internal1;
      b2 = b1;
      shiftY = 1;
      /*zzzYYY*/
      fprintf(markspots->f, "* doubleY: case 2a\n");
    } else {
      /* Neither are inside; this occurs when one deletes
         on the left edge.  So reduce to the edge and put
         the mark to the left of that base (no shift). */
      b1 = internal2;
      reduceposition(pie, &b1);
      b2 = b1;
      shiftY = 0;
      fprintf(markspots->f, "* doubleY: case 2b\n");
    }
  }

  /* lowerbits */
  /* upperbits */
  fprintf(markspots->f, "U %*ld %*.*f %*ld %*.*f %ld doubleY\n",
	  widbase, inttopie(b1, pie), widbits, decbits, insertlowerbits,
	  widbase, inttopie(b2, pie), widbits, decbits, insertupperbits,
	  shiftY);
}

/* Local variables for createmark: */
struct LOC_createmark {
  struct LOC_readinstruction *LINK;
  _TEXT *markspots;
} ;

/* piece coordinates corresponding to the
    internal coordinates b1 and b2 */
Local Void kind(c_, LINK)
Char c_;
struct LOC_createmark *LINK;
{
  /* show the kind of thing we are marking */
  switch (c_) {

  case 'd':
    fprintf(LINK->markspots->f, "deletion");
    break;

  case 'i':
    fprintf(LINK->markspots->f, "insertion");
    break;

  case 'f':
    fprintf(LINK->markspots->f, "full");
    break;

  case 'l':
    fprintf(LINK->markspots->f, "left");
    break;

  case 'm':
    fprintf(LINK->markspots->f, "mid");
    break;

  case 'r':
    fprintf(LINK->markspots->f, "right");
    break;
  }
}

Local Void createmark(markspots_, b1, b2, boxposition, changetype, pie,
		      insertupperbits, insertlowerbits, deleteupperbits,
		      deletelowerbits, LINK)
_TEXT *markspots_;
long b1, b2;
Char boxposition, changetype;
piece *pie;
double insertupperbits, insertlowerbits, deleteupperbits, deletelowerbits;
struct LOC_readinstruction *LINK;
{
  /* internal coordinates */
  /* upperbits for insertion symbol */
  /* upperbits for insertion symbol */
  /* upperbits for deletion symbol */
  /* upperbits for deletion symbol */
  /* Create box marks for an insertion or deletion.
Boxes are defined to be AROUND the given position.
Internal coordinates are used to allow the routine to be called
in a loop.  The routine writes external (piece) coordinates out.
No marks are made if either end of the object is off the piece.
*/
  struct LOC_createmark V;
  double lowerbits, upperbits;   /* the vertical range of the mark */
  long piecebase1, piecebase2;

  /*
writeln(markspots,'* createmark, changetype = ',changetype);
*/

  V.LINK = LINK;
  V.markspots = markspots_;
  if (!(withininternal(pie, b1) & withininternal(pie, b2)))
    return;
  switch (changetype) {

  case 'd':
    lowerbits = deletelowerbits;
    upperbits = deleteupperbits;
    break;

  case 'i':
    lowerbits = insertlowerbits;
    upperbits = insertupperbits;
    break;
  }
  piecebase1 = inttopie(b1, pie);
  piecebase2 = inttopie(b2, pie);
  fprintf(V.markspots->f, "U %*ld %*.*f %*ld %*.*f %*d",
	  widbase, piecebase1, widbits, decbits, lowerbits, widbase,
	  piecebase2, widbits, decbits, upperbits, widbits, 0);
      /* no displacement */
  fprintf(V.markspots->f, " (");
  kind(boxposition, &V);
  kind(changetype, &V);
  fprintf(V.markspots->f, ") ");
  kind(boxposition, &V);
  kind(changetype, &V);
  putc('\n', V.markspots->f);
}

Local Void multimarks(markspots, internal1, internal2, changetype, pie,
		      insertupperbits, insertlowerbits, deleteupperbits,
		      deletelowerbits, LINK)
_TEXT *markspots;
long internal1, internal2;
Char changetype;
piece *pie;
double insertupperbits, insertlowerbits, deleteupperbits, deletelowerbits;
struct LOC_readinstruction *LINK;
{
  /* upperbits for insertion symbol */
  /* upperbits for insertion symbol */
  /* upperbits for deletion symbol */
  /* upperbits for deletion symbol */
  /* create multiple marks to file markspots to represent a deletion
(changetype = 'd') or insertion (changetype = 'i'), for the range internal1 to
internal2.  The routine only uses internal coordinates. */
  long partindex;
      /* an index for the marker parts of insertion or deletion */

  fprintf(markspots->f, "* Multimarks, changetype = %c\n", changetype);
  fprintf(markspots->f, "* internal1 = %ld\n", internal1);
  fprintf(markspots->f, "* internal2 = %ld\n", internal2);
  if (internal1 == internal2) {
    createmark(markspots, internal1, internal2, 'f', changetype, pie,
	       insertupperbits, insertlowerbits, deleteupperbits,
	       deletelowerbits, LINK);
    return;
  }
  createmark(markspots, internal1, internal1, 'l', changetype, pie,
	     insertupperbits, insertlowerbits, deleteupperbits,
	     deletelowerbits, LINK);
  partindex = internal1 + 1;
  while (partindex < internal2) {
    createmark(markspots, partindex, partindex, 'm', changetype, pie,
	       insertupperbits, insertlowerbits, deleteupperbits,
	       deletelowerbits, LINK);
    /*
writeln(markspots,'* multimarks: partindex = ',partindex:1);
*/
    partindex++;
  }
  createmark(markspots, internal2, internal2, 'r', changetype, pie,
	     insertupperbits, insertlowerbits, deleteupperbits,
	     deletelowerbits, LINK);
}  /* multimarks */

Local Void setinternal(changes, pie, LINK)
changeset *changes;
piece *pie;
struct LOC_readinstruction *LINK;
{
  /* piece for these changes */
  /* Determine the internal coordinates for each change in the changeset */
  long hold;   /* holding variable to switch internal1 and internal2 */
  long n;   /* counter for the changes */
  long FORLIM;
  changedata *WITH;

  FORLIM = changes->number;
  /*
writeln(marksdelila,'* setinternal==========================');
*/
  /* Obtain internal coordinates for each changedata */
  for (n = 0; n < FORLIM; n++) {
    WITH = &changes->data[n];
    /* Convert to internal coordinates, without wrapping */
    WITH->internal1 = nwpietoint(WITH->basecoo1, pie);
    WITH->internal2 = nwpietoint(WITH->basecoo2, pie);
    /*writeln(marksdelila,'* setinternal: internal1 = ',internal1:1);*/
    /*writeln(marksdelila,'* setinternal: internal2 = ',internal2:1);*/
    /* handle reversed coordinate system */
    if (WITH->internal1 > WITH->internal2) {
      hold = WITH->internal2;
      WITH->internal2 = WITH->internal1;
      WITH->internal1 = hold;
      /*
writeln(marksdelila,'* setinternal: FLIP ');
*/
    }
    /*
       end;
    */
    /*
else writeln(marksdelila,'* setinternal: NO FLIP ');
*/

    /* move insertions to the end of their regions - simplifies
       all later code! */
    if (WITH->changetype == 'i') {
      /* handle cases off ends.  Note that nwpietoint sets out of bounds
         values to the ends */
      if (WITH->internal1 == 0 && WITH->internal2 == 0)
	WITH->internal1 = -1;
      if ((WITH->internal1 > piecelength(pie)) &
	  (WITH->internal2 > piecelength(pie))) {
	WITH->internal1--;   /* ie, piecelength */
	WITH->internal2 = WITH->internal1 + 1;
      }
      /* If the insert locations are far apart, then mark the part
         deleted.  Otherwise leave it alone. */
      if (labs(WITH->internal1 - WITH->internal2) == 1)
	WITH->insertasdeletion = false;
      else {
	WITH->insertasdeletion = true;
	/*PPP*/
      }
    }

    /*
writeln(marksdelila,'* setinternal: n = "',n:1,'"');
writeln(marksdelila,'* setinternal: changetype = "',changetype:1,'"');
writeln(marksdelila,'* setinternal: basecoo1 = ',basecoo1:1);
writeln(marksdelila,'* setinternal: basecoo2 = ',basecoo2:1);
writeln(marksdelila,'* setinternal: internal1 = ',internal1:1);
writeln(marksdelila,'* setinternal: internal2 = ',internal2:1);
writeln(marksdelila,'* adjusted external     = ',inttopie(internal1,pie):1);
writeln(marksdelila,'* adjusted external     = ',inttopie(internal2,pie):1);
writeln(marksdelila,'* insertasdeletion: ',insertasdeletion);
*/

    /*
bwpie(output,pie);
*/
  }
}

Local Void skippiece(marksdelila, LINK)
_TEXT *marksdelila;
struct LOC_readinstruction *LINK;
{
  /* skip to the next piece */
  fprintf(marksdelila->f, "\npiece #%ld - skip ahead to next piece\n",
	  def.num.item);
}

Local Void writewildtypemarks(markspots, changes, insertupperbits,
  insertlowerbits, deleteupperbits, deletelowerbits, changeupperbits,
  changelowerbits, pie, thenumber, LINK)
_TEXT *markspots;
changeset changes;
double insertupperbits, insertlowerbits, deleteupperbits, deletelowerbits,
       changeupperbits, changelowerbits;
piece *pie;
long thenumber;
struct LOC_readinstruction *LINK;
{
  /* upperbits for insertion symbol */
  /* upperbits for insertion symbol */
  /* upperbits for deletion symbol */
  /* upperbits for deletion symbol */
  /* upperbits for change symbol */
  /* upperbits for change symbol */
  /* piece for these changes */
  /* the piece number */
  /* Write the marks to file markspots, at the locations defined.
Writemarks works with two sequences, first is the wild-type sequence and second
is the mutant sequence.
Definition:  This routine assumes that all previous actions have placed
us onto the wild-type sequence.
NOTE: the internal values changes get modified locally here but are
not altered in the original copy.
*/
  /* shift down the change mark arrow on wt sequence.
{zzz}                This should be removed by changing the definition. */
  long chorient;
  /* orientation of the change on a piece.
       This is needed to switch the order of deletion marks. */
  long n;   /* counter for the changes */
  changeset sorted;
  /* the changes sorted by the exact positions of the
                        marks, must be done for both wild and mutant
                        sequences */
  long thelength;   /* the length of pie */
  changeset unsorted;   /* the exact positions of the marks, unsorted */
  long FORLIM;
  changedata *WITH;

  fprintf(markspots->f, "\n* piece #%ld ", thenumber);
  /*
writeln(markspots,'* writeWILDTYPEmarks');
*/
  writechangeset(markspots, changes);
  putc('\n', markspots->f);
  if (pie->key.piedir == pie->key.coodir)
    chorient = 1;
  else
    chorient = -1;
  /*
not needed
     displacement := chorient;
  */
  thelength = piecelength(pie);

  /*
writeln(markspots,'* chorient = ',chorient:1);
writeln(markspots,'* thelength = ',thelength:1);
*/

  /* first do the wild type sequence: */
  /*zzzppp*/
  /*Othis should probably be removed - no propagation for wild type
because the change coordinates refer to wild type */
  /* OLD CODE:
     propagatechanges(changes,unsorted,true); (* wild type *)
  */

  /* No propagation for wild type because the change coordinates refer to
     wild type */
  unsorted = changes;

  FORLIM = unsorted.number;
  /* adjust the locations of the marks */
  /*zzz probably eliminate entire section, it's not used now*/

  for (n = 0; n < FORLIM; n++) {
    WITH = &unsorted.data[n];
    /*
writeln(markspots,'* basecoo1 = ',basecoo1:1);
writeln(markspots,'* basecoo2 = ',basecoo2:1);
writeln(markspots,'* internal1 = ',internal1:1);
writeln(markspots,'* internal2 = ',internal2:1);
*/
    switch (WITH->changetype) {

    case 'c':   /* wait until the next loop */
      break;

    case 'i':
      /* blank case */
      break;

    /*
shifting of the inserts should be done at output, so I
am blocking this segment for now.
it is not clear how badly not doing this will affect sorting
                  if chorient = +1 then begin
                     internal1 := shiftbase(internal1,+1);
                     internal2 := shiftbase(internal2,-1);
                  end
                  else begin
                     internal1 := shiftbase(internal1,-1);
                     internal2 := shiftbase(internal2,+1);
                  end;
writeln(markspots,'* chorient internal1 = ',internal1:1);
writeln(markspots,'* chorient internal2 = ',internal2:1);
    */
    case 'd':
      break;
      /* mark deletion as a red bar on the wild type
         sequence */
    }
  }
  sortchanges(unsorted, &sorted, 'w', LINK);

  FORLIM = sorted.number;
  /*
writeln(markspots,'** MARKSPOTS *********************************************');
write(markspots,'*U WILD external ');
write(markspots,'unsorted: '); writechangeset(markspots,unsorted); writeln(markspots);
write(markspots,'*U WILD external ');
write(markspots,'sorted:   '); writechangeset(markspots,sorted);   writeln(markspots);
write(markspots,'*U WILD internal ');
write(markspots,'unsorted: '); checkchangeset(markspots,unsorted); writeln(markspots);
write(markspots,'*U WILD internal ');
write(markspots,'sorted:   '); checkchangeset(markspots,sorted);   writeln(markspots);
writeln(markspots,'********************************************************');
*/

  /* print the marks out for wildtype sequence */
  for (n = 0; n < FORLIM; n++) {
    WITH = &sorted.data[n];
    switch (WITH->changetype) {

    case 'c':
      fprintf(markspots->f,
	      "U %*ld %*.*f %*ld %*.*f %*.*f (%c->%c) changeworra \n",
	      widbits, inttopie(WITH->internal1, pie), widbits, decbits,
	      changeupperbits - shiftdown, widbits,
	      inttopie(WITH->internal2, pie), widbits, decbits,
	      changelowerbits - shiftdown, widbits, decbits, 0.0,
	      WITH->baseold, WITH->basenew);
      /*TTT this is old!!!*/
      /*
                  writeln(markspots,'U',
                        ' ',inttopie(internal1-displacement,pie):widbits:decbits,
                        ' ',changeupperbits-shiftdown:widbits:decbits,
                        ' ',inttopie(internal2-displacement,pie):widbits:decbits,
                        ' ',changelowerbits-shiftdown:widbits:decbits,
                        ' ',+displacement:widbits:decbits,
                        ' (', baseold,
                        '->', basenew,
                        ') changeworra ')
      */
      break;

    case 'i':
      /*
                     internal1 := internal1 + 1;
                     internal2 := internal2 + 1;
messes up
      */
      /*NNN*/
      /*
                     internal1 := thelength;
                     internal2 := thelength;
handled in setinternal
      */
      /*note: I'm guessing that this is the right thing to do
rather than just subtracting 1!
*/

      fprintf(markspots->f, "* alive\n");
      fprintf(markspots->f, "* basecoo1 = %ld\n", WITH->basecoo1);
      fprintf(markspots->f, "* basecoo2 = %ld\n", WITH->basecoo2);
      fprintf(markspots->f, "* internal1 = %ld\n", WITH->internal1);
      fprintf(markspots->f, "* internal2 = %ld\n", WITH->internal2);


      /*YY*/
      /*
writeln(markspots,'* insertasdeletion: ',insertasdeletion);
*/

      /*
simplify:
                  if (1 = abs(internal1 - internal2)) and (not insertasdeletion)
      */
      if (WITH->insertasdeletion)
	multimarks(markspots, WITH->internal1 + 1, WITH->internal2 - 1, 'd',
		   pie, insertupperbits, insertlowerbits, deleteupperbits,
		   deletelowerbits, LINK);
      else
	doubleYmark(markspots, WITH->internal1, WITH->internal2, pie,
		    insertlowerbits, insertupperbits, LINK);
      break;
      /* mark insertion location as a black bar on the wild type
         sequence */
      /*
this is probably important to keep - done below - is it right?
                  (* handle the special cases of
                     insertion at the ends of the sequence *)
                  if (nwpietoint(trunc(basecoo1),pie) = 0)
                  then begin
                     basecoo1 := basecoo1 + 1.0;
                     basecoo2 := basecoo2 + 1.0;
                     displacement := -1.8; (* I don't know why this needs more *)
                  end;
                  if (nwpietoint(trunc(basecoo1),pie) > piecelength(pie))
                  then begin
                     basecoo1 := basecoo1 - 1.0;
                     basecoo2 := basecoo2 - 1.0;
                     displacement := 0.0;
                  end;
      */
      /* handle the special cases of
         insertion at the ends of the sequence */

    case 'd':
      /* mark deletion as a red bar on the wild type sequence */
      multimarks(markspots, WITH->internal1, WITH->internal2, 'd', pie,
		 insertupperbits, insertlowerbits, deleteupperbits,
		 deletelowerbits, LINK);
      break;
    }
  }
}

#undef shiftdown

/*WWWW 3*/

Local Void writemutantmarks(markspots, changes, insertupperbits,
  insertlowerbits, deleteupperbits, deletelowerbits, changeupperbits,
  changelowerbits, pie, thenumber, LINK)
_TEXT *markspots;
changeset changes;
double insertupperbits, insertlowerbits, deleteupperbits, deletelowerbits,
       changeupperbits, changelowerbits;
piece *pie;
long thenumber;
struct LOC_readinstruction *LINK;
{
  /* upperbits for insertion symbol */
  /* upperbits for insertion symbol */
  /* upperbits for deletion symbol */
  /* upperbits for deletion symbol */
  /* upperbits for change symbol */
  /* upperbits for change symbol */
  /* piece for these changes */
  /* the piece number */
  /* Write the marks to file markspots, at the locations defined.
Writemarks works with two sequences, first is the wild-type sequence and second
is the mutant sequence.
Definition:  This routine assumes that all previous actions have placed
us onto the wild-type sequence.
NOTE: the internal values changes get modified locally here but are
not altered in the original copy.
*/
  long displacement;
  /* number of bases to displace the mark
                            backwards */
  long chorient;
  /* orientation of the change on a piece.
       This is needed to switch the order of deletion marks. */
  long n;   /* counter for the changes */
  changeset sorted;
  /* the changes sorted by the exact positions of the
                        marks, must be done for both wild and mutant
                        sequences */
  long thelength;   /* the length of pie */
  changeset unsorted;   /* the exact positions of the marks, unsorted */
  long FORLIM;
  changedata *WITH;

  fprintf(markspots->f, "\n* piece #%ld ", thenumber);
  /*
writeln(markspots,'* writeMUTANTmarks');
*/
  writechangeset(markspots, changes);
  putc('\n', markspots->f);
  if (pie->key.piedir == pie->key.coodir)
    chorient = 1;
  else
    chorient = -1;
  displacement = chorient;
  thelength = piecelength(pie);

  /*
writeln(markspots,'* chorient = ',chorient:1);
writeln(markspots,'* thelength = ',thelength:1);
*/

  /*original:
     write(markspots,'p - skip ahead to mutated piece');
     writeln(markspots,' #',(thenumber+1):1);  (* anticipate its number *)
  */

  /*zzzppp*/
  /*
     propagatechanges(changes,unsorted,false); (* mutant *)
  */

  unsorted = changes;
  FORLIM = unsorted.number;

  for (n = 1; n <= FORLIM; n++)
    propagateonechange(&unsorted, n, pie, LINK);
  FORLIM = unsorted.number;
  /* create marks for mutant sequence */
  /* better title?  set coordinates of marks for mutant sequence */

  for (n = 0; n < FORLIM; n++) {
    WITH = &unsorted.data[n];
    /*
writeln(markspots,'* writeMUTANTmarks basecoo1 = ',basecoo1:1);
writeln(markspots,'* writeMUTANTmarks basecoo2 = ',basecoo2:1);
writeln(markspots,'* writeMUTANTmarks inserts = ',inserts:6);
writeln(markspots,'* writeMUTANTmarks internal1 = ',internal1:1);
writeln(markspots,'* writeMUTANTmarks internal2 = ',internal2:1);
*/
    switch (WITH->changetype) {

    case 'c':
      /* blank case */
      break;

    /*
NO!!???
                internal1 := internal1 - displacement; (* still valid? *)
                internal2 := internal1;
    */
    case 'i':
      if (WITH->inserts == 0) {
	WITH->internal2 = WITH->internal1 + 1;
	/*
writeln(markspots,'* ADJUST a: ON THE NOSE');
*/
      } else {
	/*
writeln(markspots,'* ADJUST b: ON THE NOSE');
*/
	WITH->internal1++;
	WITH->internal2 = WITH->internal1 + WITH->inserts - 1;
      }
      break;
      /*
writeln(markspots,'* VOILA ADJUST internal1 = ',internal1:1);
writeln(markspots,'* VOILA ADJUST internal2 = ',internal2:1);
*/


    case 'd':
      break;
    }
  }
  sortchanges(unsorted, &sorted, 'm', LINK);

  FORLIM = sorted.number;
  /*
writeln(markspots,'*2***********************************************************');
write(markspots,'* MUTANT external ');
write(markspots,'unsorted: '); writechangeset(markspots,unsorted); writeln(markspots);
write(markspots,'* MUTANT external ');
write(markspots,'sorted:   '); writechangeset(markspots,sorted);   writeln(markspots);
write(markspots,'* MUTANT internal ');
write(markspots,'unsorted: '); checkchangeset(markspots,unsorted); writeln(markspots);
write(markspots,'* MUTANT internal ');
write(markspots,'sorted:   '); checkchangeset(markspots,sorted);   writeln(markspots);
writeln(markspots,'*3***********************************************************');
*/

  /* mutant */

  /*
write(markspots,'*N sorted:   '); checkchangeset(markspots,sorted);   writeln(markspots);
write(markspots,'*N unsorted: '); checkchangeset(markspots,unsorted);   writeln(markspots);
write(markspots,'*N changes:  '); checkchangeset(markspots,changes);   writeln(markspots);

write(markspots,'*N sorted:   '); writechangeset(markspots,sorted);   writeln(markspots);
write(markspots,'*N unsorted: '); writechangeset(markspots,unsorted);   writeln(markspots);
write(markspots,'*N changes:  '); writechangeset(markspots,changes);   writeln(markspots);
*/

  /*
     writeln(markspots,'p - skip ahead to next piece');
  */
  for (n = 0; n < FORLIM; n++) {
    WITH = &sorted.data[n];
    switch (WITH->changetype) {

    case 'c':
      fprintf(markspots->f,
	      "U %*ld %*.*f %*ld %*.*f %*.*f (%c->%c) change \n",
	      widbits, inttopie(WITH->internal1, pie), widbits, decbits,
	      changeupperbits, widbits, inttopie(WITH->internal2, pie),
	      widbits, decbits, changelowerbits, widbits, decbits, 0.0,
	      WITH->baseold, WITH->basenew);
      break;

    /*
                      ' ',displacement:widbits:decbits,
    */
    case 'i':
      /* handle the special cases of
         insertion at the ends of the sequence */
      if (WITH->internal1 == 0) {
	WITH->internal1++;
	WITH->internal2++;
      }
      if (WITH->internal1 > thelength) {
	/*
writeln(output,'nwpietoint(trunc(basecoo1),pie) = ',nwpietoint(trunc(basecoo1),pie):1);
writeln(output,'nwpietoint(trunc(basecoo2),pie) = ',nwpietoint(trunc(basecoo2),pie):1);
writeln(output,'piecelength(pie) = ',piecelength(pie):1);
*/
	WITH->internal1--;   /* assumes internal1 = thelength */
	WITH->internal2--;
      }

      fprintf(markspots->f, "* NOWH internal1 = %ld\n", WITH->internal1);
      fprintf(markspots->f, "* NOWH internal2 = %ld\n", WITH->internal2);
      if (WITH->inserts == 0)
	doubleYmark(markspots, WITH->internal1, WITH->internal2, pie,
		    insertlowerbits, insertupperbits, LINK);
      else
	multimarks(markspots, WITH->internal1, WITH->internal2, 'i', pie,
		   insertupperbits, insertlowerbits, deleteupperbits,
		   deletelowerbits, LINK);

      fprintf(markspots->f, "* VOILA internal1 = %ld\n", WITH->internal1);
      fprintf(markspots->f, "* VOILA internal2 = %ld\n", WITH->internal2);

      break;

    case 'd':  /* mark the point between bases of the deletion */
      /* slide back to point just before deletion: */
      WITH->internal1--;
      /* make second base match first base: */
      WITH->internal2 = WITH->internal1 + 1;
      fprintf(markspots->f, "* writeMUTANTmarks DELETION internal1 = %ld\n",
	      WITH->internal1);
      fprintf(markspots->f, "* writeMUTANTmarks DELETION internal2 = %ld\n",
	      WITH->internal2);
      doubleYmark(markspots, WITH->internal1, WITH->internal2, pie,
		  insertlowerbits, insertupperbits, LINK);
      break;
    }
  }
}

/*WW*/
/*WWW*/
/*WWW*/

/* originally from version = 1.89; (@ of dbmutate.p 1999 April 26 */
/* end module delila.writemarks */

/**************************************************************************/
/**************************************************************************/
/**************************************************************************/

/* routines for extracting pieces */

Local Void dnaconcat(Adna, Bdna, Cdna, LINK)
dnastring *Adna, *Bdna, **Cdna;
struct LOC_readinstruction *LINK;
{
  /* concatenate Adna to Bdna, put in Cdna */
  dnastring *aDNAptr;   /* pointer into Adna */
  dnastring *bDNAptr;   /* pointer into Bdna */
  dnastring *cpart;   /* a new part for Cdna */
  long pb = 1;   /* position in b */
  long pc;   /* position in c */
  long TEMP;

  emptydna(Cdna);
  getdna(Cdna);
  cpart = *Cdna;
  /* copy a into c */
  aDNAptr = Adna;
  while (aDNAptr != NULL) {
    memcpy(cpart->part, aDNAptr->part, sizeof(seq));
    cpart->length = aDNAptr->length;
    aDNAptr = aDNAptr->next;
    if (aDNAptr != NULL) {
      getdna(&cpart->next);
      cpart = cpart->next;
    } else
      cpart->next = NULL;
  }

  /* now copy b into c and compact */
  pc = cpart->length;
  bDNAptr = Bdna;
  do {
    if (cpart->length == dnamax) {
      getdna(&cpart->next);
      cpart = cpart->next;
      cpart->next = NULL;
      cpart->length = 1;
    } else {
      cpart->length++;

    }
    TEMP = cpart->length - 1;
    P_clrbits_B(cpart->part, TEMP, 1, 3);
    P_putbits_UB(cpart->part, TEMP,
		 (int)((base)P_getbits_UB(bDNAptr->part, pb - 1, 1, 3)), 1,
		 3);
    pb++;

    if (pb > bDNAptr->length) {
      bDNAptr = bDNAptr->next;
      pb = 1;
    }
  } while (bDNAptr != NULL);
}

Local Void dnacomplement(Adna, Bdna, LINK)
dnastring *Adna, **Bdna;
struct LOC_readinstruction *LINK;
{
  /* make the complement of Adna in Bdna */
  dnastring *a_;   /* pointer into Adna */
  dnastring *bpart;   /* a new part for Bdna */
  long p;   /* position in a */
  boolean done = false;   /* done complementing? */
  long FORLIM, TEMP;

  /*
writeln(output,'dnacomplement');
*/
  emptydna(Bdna);
  getdna(Bdna);
  bpart = *Bdna;
  a_ = Adna;
  while (!done) {
    bpart->length = a_->length;
    FORLIM = a_->length;
    for (p = 1; p <= FORLIM; p++) {
      TEMP = a_->length - p;
      P_clrbits_B(bpart->part, TEMP, 1, 3);
      P_putbits_UB(bpart->part, TEMP,
		   (int)complement((base)P_getbits_UB(a_->part, p - 1, 1, 3)),
		   1, 3);
    }
    if (a_->next == NULL) {
      done = true;
      /*
writeln(output,'(a^.next = nil) is ', (a^.next = nil));
*/
      break;
    }
    bpart = (dnastring *)Malloc(sizeof(dnastring));
    /*
writeln(output,'new(bpart)');
*/
    bpart->next = *Bdna;
    *Bdna = bpart;
    a_ = a_->next;
  }
  /*
writeln(output,'about to crash in dnacomplement');
crash;
*/
}

Local Void getdnasegment(big, little, s, e, LINK)
dnastring *big, **little;
long s, e;
struct LOC_readinstruction *LINK;
{
  /* create the dna segment from s (start) to e (end) of a big dna.  Both s and
e are INTERNAL coordinates, 1 to the length of a dna.  */
  long b;   /* position in a bDNAptr segment */
  dnastring *bDNAptr;   /* pointer to big dna */
  long l = 0;   /* position in an ldna segment */
  dnastring *ldna;   /* pointer to little dna */
  long p;   /* position from s to e */

  /*
writeln(output, 'about to getdnasegment !!!!!!!!!!!!!!!!!!!!'); {zzzddd}
*/
  if (s > e) {
    printf("getdnasegment: s < e is required\n");
    halt();
  }

  bDNAptr = big;
  /*
writeln(output,'s = ',s:1);
writeln(output,'e = ',e:1);
writeln(output,'bDNAptr^.length = ',bDNAptr^.length:1);
*/

  /* get p to s-1 in big */
  p = bDNAptr->length;
  if (p < s - 1) {
    while (p < s - 1) {
      if (bDNAptr->next == NULL) {
	printf("getdnasegment: request off end of piece\n");
	halt();
      }
      bDNAptr = bDNAptr->next;
      p += bDNAptr->length;
      /*
         ;writeln(output,'STEPPPPPPPP p = ',p:1);
      */
    }
    b = bDNAptr->length - p + s - 1;
    /* the point of start in this segment is p-s, but back up one position
       so that the loop can advance us into place */

  } else
    b = s - 1;
  /* back one position so that the loop can advance us into
     place */
  emptydna(little);
  getdna(little);
  ldna = *little;
  for (p = s; p <= e; p++) {
    /* prepare the little to receive */
    l++;
    if (l > dnamax) {  /* shift to next little segment */
      /*
writeln(output,'getdnasegment: NEW SEGMENT'); {zzzddd}
*/
      ldna->length = dnamax;
      getdna(&ldna->next);
      ldna = ldna->next;
      l = 1;
      /*
writeln(output,'ldna^.length = ',ldna^.length:1);{zzzddd}
*/
    }

    b++;

    /*zzzooo*/
    if (b > bDNAptr->length) {  /* shift to next big segment */
      /*
writeln(output,'b = ',b:1);
*/
      if (bDNAptr->next == NULL) {
	printf("getdnasegment: request e (%ld) is beyond piece end\n", e);
	crash();
	halt();
      }
      /*
writeln(output,'next segment');
*/
      b = 1;
      bDNAptr = bDNAptr->next;
    }

    P_clrbits_B(ldna->part, l - 1, 1, 3);
    P_putbits_UB(ldna->part, l - 1,
		 (int)((base)P_getbits_UB(bDNAptr->part, b - 1, 1, 3)), 1, 3);
  }
  /* transfer the base */
  /*
write  (output,'getdnasegment ');
write  (output,basetochar(ldna^.part[l]));
write  (output,' p=',p:1);
write  (output,' l=',l:1);
writeln(output,' b=',b:1);
if basetochar(ldna^.part[l]) = 'X' then crash;
zzzddd
*/
  ldna->length = l;

  /*
writeln(output,'l = ',l:1);
writeln(output,'  ',
'123456789 123456789 123456789 123456789 123456789 123456789 123456789 1234567890');
writeln(output,'  ',
'         1         2         3         4         5         6         7         8');
writeln(output, 'getdnasegment -----BIG------------'); {zzzddd}
LIKEbwdna(output,big); {zzzddd}
writeln(output, 'getdnasegment -----LITTLE---------'); {zzzddd}
LIKEbwdna(output,little); {zzzddd}
writeln(output, 'END   to getdnasegment !!!!!!!!!!!!!!!!!!!!'); {zzzddd}
*/
}  /* getdnasegment */

/* Local variables for circledna: */
struct LOC_circledna {
  struct LOC_readinstruction *LINK;
} ;

Local Void invert(d, LINK)
dnastring **d;
struct LOC_circledna *LINK;
{
  /* complement the dna in d */
  dnastring *i;

  i = *d;
  *d = NULL;
  dnacomplement(i, d, LINK->LINK);
  /* 1999 April 27 forgetting the following cleardna caused a memory leak! */
  cleardna(&i);
}

Local Void circledna(big, little, s, e, inverting, LINK)
piece *big, **little;
long s, e;
boolean inverting;
struct LOC_readinstruction *LINK;
{
  /* Extract a segment of a big dna, treated as a circle.  Both s (start) and e
(end) are internal coordinates that must be inside the big piece.  There are
4 possible cases:
     1<-s  e<-n     inverting
     1  s->e  n not inverting
     1  e<-s  n     inverting
     1->e  s->n not inverting
1 and n are the ends of big.  -> means the segment that is given
5' to 3'.  */
  struct LOC_circledna V;
  /*zzzddd*/
  dnastring *first;   /* first dna bit to grab */
  long n;   /* length of big */
  dnastring *second;   /* second dna bit to grab */

  V.LINK = LINK;
  n = piecelength(big);
  /*zzzddd*/
  /*
writeln(output, 'about to circledna --------------------');
writeln(output,'circledna, n = ',n:1);
writeln(output,'s = ',s:1);
writeln(output,'e = ',e:1);
writeln(output,'inverting = ',inverting);
*/
  if (s < e) {
    if (inverting) {  /* 1<-s e<-n     inverting */
      if (showcase)
	printf("    1<-s e<-n     inverting\n");
      first = NULL;
      second = NULL;
      getdnasegment(big->dna, &first, 1L, s, LINK);
      invert(&first, &V);
      getdnasegment(big->dna, &second, e, n, LINK);
      invert(&second, &V);
      dnaconcat(first, second, &(*little)->dna, LINK);
      cleardna(&first);
      cleardna(&second);
      return;
    }
    if (showcase)
      printf("1  s->e  n not inverting\n");
    getdnasegment(big->dna, &(*little)->dna, s, e, LINK);
    return;
  }
  /* 1  s->e  n not inverting */
  if (s > e) {
    if (inverting) {  /* 1  e<-s  n     inverting */
      if (showcase)
	printf("    1  e<-s  n     inverting\n");
      getdnasegment(big->dna, &(*little)->dna, e, s, LINK);
      /*
writeln(output,'gotsegment little^.dna');
*/
      /*
;writeln(output,'inverted little^.dna');
;crash;{zzzddd}
*/
      invert(&(*little)->dna, &V);
      return;
    }
    if (showcase)
      printf("1->e  s->n not inverting\n");
    first = NULL;
    second = NULL;
    getdnasegment(big->dna, &first, s, n, LINK);
    getdnasegment(big->dna, &second, 1L, e, LINK);
    dnaconcat(first, second, &(*little)->dna, LINK);
    cleardna(&first);
    cleardna(&second);
    return;
  }
  /* 1->e  s->n not inverting */
  getdnasegment(big->dna, &(*little)->dna, s, s, LINK);
  if (inverting) {
    invert(&(*little)->dna, &V);
    /* s = e, so get one base */
    /*
;
writeln(output, 'about to circledna -----BIG------------'); {zzzddd}
LIKEbwdna(output, big^.dna); {zzzddd}
writeln(output, 'about to circledna -----LITTLE---------'); {zzzddd}
LIKEbwdna(output, little^.dna); {zzzddd}
writeln(output, 'about to circledna -----DONE-----------'); {zzzddd}
*/
  }
}

#undef showcase

Local Void compress(pie, LINK)
piece **pie;
struct LOC_readinstruction *LINK;
{
  /* after deletion of bases, it is possible to have extra
dna parts at the end of a sequence.  These must be removed
so that they don't get accidentally used. */
  long p;   /* the last base of the dna part */
  long pielength;   /* current length of the piece */
  long previous = 0;   /* length of the all previous segments */
  dnastring *workdna;   /* current working dna segment */

  /*
writeln(output,'compresssssssssssssssssssssssssssssssssssss');
bwpie(output,pie);
*/
  pielength = piecelength(*pie);
  /* find end of used pie */
  workdna = (*pie)->dna;
  p = workdna->length;
  while (pielength > p && workdna->next != NULL) {
    /*
writeln(output,'NNNNNNNNNNNNNNNNNNNNnnooooooooooooooooooooo');
*/
    previous += workdna->length;
    workdna = workdna->next;
    p += workdna->length;
  }
  /* At this point, p is the total length including the workdna
     segment.  p is larger than pielength.  previous is the amount
     prior to this link.  So we need to set
     the workdna length to pielength - previous. */
  /*
writeln(output, 'pielength = ',pielength:1);
writeln(output, 'p = ',p:1);
writeln(output, 'pielength - previous = ',(pielength - previous):1);
*/
  workdna->length = pielength - previous;
  if (workdna->next != NULL)
    emptydna(&workdna->next);
  /*
bwpie(output,pie);
writeln(output,'END   sssssssssssssssssssssssssssssssssssss');
*/
  /*zzzyyy*/
}

/* begin module fixpiececoordinate */
Local Void fixpiececoordinate(pie, excess, coordinateside, LINK)
piece **pie;
long excess;
direction coordinateside;
struct LOC_readinstruction *LINK;
{
  /* Fix the piece coordinates for insertions or deletions.  Coordinateside is
the end of the coordinate system that gets changed */
  piekey *WITH;

  /*
writeln(output,'fixpiececoordinate: excess = ',excess:1);
*/
  WITH = &(*pie)->key;
  switch (coordinateside) {

  case minus:
    switch (WITH->piedir) {

    case minus:
      /* piedir minus coordinateside minus */
      WITH->pieend -= excess;
      WITH->coobeg -= excess;
      break;

    case plus:
      /* piedir plus coordinateside minus */
      WITH->piebeg -= excess;
      WITH->coobeg -= excess;
      break;
    }
    break;

  case plus:
    switch (WITH->piedir) {

    case minus:
      /* piedir minus coordinateside plus */
      WITH->piebeg += excess;
      WITH->cooend += excess;
      break;

    case plus:
      /* piedir plus coordinateside plus */
      WITH->pieend += excess;
      WITH->cooend += excess;
      break;
    }
    break;
  }
}

/* end module fixpiececoordinate version = 7.52; {of delmod.p 2000 Jul 30} */

/* begin module book.putbase */
Local Void putbase(b, position_, pie, coordinateside, LINK)
base b;
long position_;
piece **pie;
direction coordinateside;
struct LOC_readinstruction *LINK;
{
  /* put a base b into the nth position (internal coordinates) of the
     piece.  Protection is made against positions outside the piece.
NEW:
* If the base is before coordinate 1, the program halts.
* If the base is after the end of the sequence, extra space is made, and
    the coordinate system is changed on the coordinate side given.
  */
  long excess;   /* the implied insertion size */
  dnastring *workdna;   /* working dna segment */
  long p;   /* the last base of the dna part or current length */
  long pielength;   /* current length of the piece */
  long TEMP;

  /*
z: integer; (* index to the piece for debuging stuff *)
*/
  pielength = piecelength(*pie);
  /*
writeln(output,'putbase ==================================');
write  (output,'putbase: b = ',basetochar(b),', pielength=',pielength:1);
writeln(output,', position=',position:1);
*/
  if (position_ < 1) {
    printf(
      "putbase: can not put bases before the start of the piece (position < 1)\n");
    printf("Program error!  Please report it to toms@ncifcrf.gov.\n");
    halt();
  }
  workdna = (*pie)->dna;
  if (position_ > pielength) {  /* add to end of piece */
    /*
writeln(output,'putbase: INCREMENT WORKDNA');
*/
    /* since position > pielength, excess is always positive */
    excess = position_ - pielength;
    fixpiececoordinate(pie, excess, coordinateside, LINK);
    /*
writeln(output,'putbase: excess=',excess:1);
*/

    /* find the last segment */
    p = workdna->length;
    while (workdna->next != NULL) {
      /*
writeln(output,'looping');
*/
      workdna = workdna->next;
      p += workdna->length;
    }
    /*
writeln(output,'USED SPACE is p=',p:1);
*/

    if (workdna->length + excess <= dnamax) {
      /* fill into the available segment */
      /*
writeln(output,'NO NEW SEGMENTS NEEDED');
*/
      workdna->length += excess;
      /* insert into the current piece */

      /*
showsegments(output,pie^.dna);
;writeln(output,'putbase: p=',p:1);
;writeln(output,'putbase: dnamax=',dnamax:1);
;writeln(output,'putbase: position=',position:1);
;writeln(output,'==========================================');
*/

      TEMP = workdna->length - 1;
      P_clrbits_B(workdna->part, TEMP, 1, 3);
      P_putbits_UB(workdna->part, TEMP, (int)b, 1, 3);
      return;
    }

    /* make the rest of the last segment useable by increasing
       its length up to dnamax, first increment p: */
    p += dnamax - workdna->length;
    workdna->length = dnamax;

    /* build enough segments to accommodate the new sequence */
    while (p < position_) {
      /*
writeln(output,' start adding segment, p = ',p:1,'--------------++++++++++');
*/
      /* now make a new segment: */
      p += dnamax;
      getdna(&workdna->next);
      workdna = workdna->next;
      workdna->length = dnamax;   /* make it all available to fill */
      /*
for z := 1 to dnamax do workdna^.part[z] := x;
writeln(output,'----------add segment, p = ',p:1);
*/
    }
    /* put the base in at the end */
    workdna->length = dnamax - p + position_;

    /*
;writeln(output,'placement, workdna^.length = ',workdna^.length:1);
showsegments(output,pie^.dna);
*/

    TEMP = workdna->length - 1;
    P_clrbits_B(workdna->part, TEMP, 1, 3);
    P_putbits_UB(workdna->part, TEMP, (int)b, 1, 3);
    return;
  }


  /*
;writeln(output,'putbase: final workdna^.length=',workdna^.length:1);
*/
  /* add new segments */
  /*
write(output,'NEW SEGMENTS NEEDED:');
write(output,' p =',p:1);
write(output,' excess =',excess:1);
writeln(output);
*/

  /*
writeln(output,'putbase: NO EXCESS');
*/
  /* locate segment in which to put the base */
  p = workdna->length;
  while (position_ > p) {
    /*
writeln(output,'THE PLACE =============!! p = ',p:1);
*/
    if (workdna->next != NULL)
      workdna = workdna->next;
    p += workdna->length;   /* only count the filled part */
    /*
writeln(output,'FINAL     =============== p = ',p:1);
writeln(output,'FINAL     =============== position=',position:1);
writeln(output,'FINAL     ===============  (position > p)=',
                                               (position > p));
writeln(output,'FINAL     ===============  (workdna^.next <> nil)=',
                                               (workdna^.next <> nil));
;writeln(output,'putbase: about to smash: workdna^.length=',workdna^.length:1);
    */
    /*
;writeln(output,'putbase: after smash: workdna^.length=',workdna^.length:1);
*/
    /*
writeln(output,'base ',b,' placed into ',
          workdna^.length - (p-position):1);
showdnasegment(output,workdna, workdna^.length);
writeln(output);
    */
  }
  TEMP = workdna->length - p + position_ - 1;
  P_clrbits_B(workdna->part, TEMP, 1, 3);
  P_putbits_UB(workdna->part, TEMP, (int)b, 1, 3);
}

/* end module book.putbase version = 7.52; {of delmod.p 2000 Jul 30} */

Local Char getbasech(position_, pie, LINK)
long position_;
piece *pie;
struct LOC_readinstruction *LINK;
{
  /* get a base from the piece at position, return as a character.
Use internal coordinates. */
  return (basetochar(getbase(position_, pie)));
}

Local Void putbasech(c_, position_, pie, coordinateside, LINK)
Char c_;
long position_;
piece *pie;
direction coordinateside;
struct LOC_readinstruction *LINK;
{
  /* put the character c as a base at the position in piece pie.
Use internal coordinates.
Change the coordinate system on the coordinate side given.
*/
  putbase(chartobase(c_), position_, &pie, coordinateside, LINK);
}

/* Local variables for numberdigit: */
struct LOC_numberdigit {
  struct LOC_readinstruction *LINK;
  long number, place;   /* the exponent of logplace */
  long myabsolute;   /* the absolute value of number */
  Char acharacter;   /* the character to be returned */
} ;

Local Void digit(LINK)
struct LOC_numberdigit *LINK;
{
  /* extract a digit at the place position */
  long tenplace;   /* ten times place */
  long z;   /* an intermediate value */
  long d;   /* the digit extracted */

  tenplace = LINK->place * 10;
  z = LINK->myabsolute - LINK->myabsolute / tenplace * tenplace;
  if (LINK->place == 1)
    d = z;
  else
    d = z / LINK->place;
  switch (d) {

  case 0:
    LINK->acharacter = '0';
    break;

  case 1:
    LINK->acharacter = '1';
    break;

  case 2:
    LINK->acharacter = '2';
    break;

  case 3:
    LINK->acharacter = '3';
    break;

  case 4:
    LINK->acharacter = '4';
    break;

  case 5:
    LINK->acharacter = '5';
    break;

  case 6:
    LINK->acharacter = '6';
    break;

  case 7:
    LINK->acharacter = '7';
    break;

  case 8:
    LINK->acharacter = '8';
    break;

  case 9:
    LINK->acharacter = '9';
    break;
  }
}  /* digit */

Local Void sign(LINK)
struct LOC_numberdigit *LINK;
{
  /* put a negative sign out or a positive sign */
  if (LINK->number < 0)
    LINK->acharacter = '-';
  else
    LINK->acharacter = '+';
}  /* sign */

/* begin module numbar.info */
/* numbar: routines that make it easy to write a bar of numbers
out on the page.  these are very convenient for making graphs.

      the function numberdigit takes a number as input, and the log (base ten)
of the place value (called logplace) desired.  a character for that spot is
returned.   example:
      numberdigit(246,2) = 2

      the function numbersize determines the number of characters required
for printing the number (including the sign).

the procedure numberbar uses numberdigit and numbersize to write a bar of
numbers into a file, with several spaces before.  the range of numbers is
specified, and the number of lines written is returned.

         example:
      numberbar(output,5,-20,20,lines);    gives

     -----------                   +++++++++++
     21111111111--------- +++++++++11111111112
     09876543210987654321012345678901234567890

      3 lines were written.

*/
/* end module numbar.info version = 4.47; (@ of prgmod.p 2000 Sep 9 */

/* begin module numberdigit */
Local Char numberdigit(number_, logplace, LINK)
long number_, logplace;
struct LOC_readinstruction *LINK;
{
  /* 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.
  */
  struct LOC_numberdigit V;
  long count;   /* used to make place */

  V.LINK = LINK;
  V.number = number_;
  V.place = 1;
  for (count = 1; count <= logplace; count++)
    V.place *= 10;

  if (V.number == 0) {
    if (V.place == 1)
      V.acharacter = '0';
    else
      V.acharacter = ' ';
    return V.acharacter;
  }
  V.myabsolute = labs(V.number);
  if (V.myabsolute < V.place / 10) {
    V.acharacter = ' ';
    return V.acharacter;
  }
  if (V.myabsolute >= V.place)
    digit(&V);
  else
    sign(&V);
  return V.acharacter;
}  /* numberdigit */

/* end module numberdigit version = 4.47; (@ of prgmod.p 2000 Sep 9 */

/* begin module numbersize */
Local long numbersize(n, LINK)
long n;
struct LOC_readinstruction *LINK;
{
  /* calculate amount of space to be reserved for the integer n */
  long size;   /* intermediate result */

  if (n == 0)
    return 1;
  else {   /* account for minus sign */
    size = (long)(log((double)labs(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)
      size++;
    return size;
  }
}  /* numbersize */

#undef ln10
#undef epsilon

/* Local variables for namechangeset: */
struct LOC_namechangeset {
  struct LOC_readinstruction *LINK;
  piece **pie;
} ;

Local Void putin(c_, LINK)
Char c_;
struct LOC_namechangeset *LINK;
{
  /* put c into the name at s */
  name *WITH;

  /*
writeln(output,'putin(',c,')');
*/
  WITH = &(*LINK->pie)->key.hea.keynam;
  if (WITH->length < namelength) {
    WITH->length++;
    WITH->letters[WITH->length - 1] = c_;
  }
}

Local Void putnumber(r, LINK)
double r;
struct LOC_namechangeset *LINK;
{
  Char c_;   /* a character in the number */
  long n;   /* index to the characters in number */
  long i;   /* round of r */

  i = (long)floor(r + 0.5);
  for (n = numbersize(i, LINK->LINK) - 1; n >= 0; n--) {
    c_ = numberdigit(i, n, LINK->LINK);
    /*
writeln(output,'i=',i);
writeln(output,'c=',c);
writeln(output,'n=',n);
*/
    if (c_ != '+')
      putin(c_, LINK);
    /*
writename(output,pie^.key.hea.keynam);
*/
  }
}

/* end module numbersize version = 4.47; (@ of prgmod.p 2000 Sep 9 */

Local Void namechangeset(pie_, changes, LINK)
piece **pie_;
changeset changes;
struct LOC_readinstruction *LINK;
{
  /* put the changeset into the piece name */
  /* this could be upgraded to be more general like linechangeset */
  struct LOC_namechangeset V;
  long i;   /* index to insertion */
  long n;   /* index to changes */
  long FORLIM;
  changedata *WITH;
  long FORLIM1;

  V.LINK = LINK;
  V.pie = pie_;
  FORLIM = changes.number;
  for (n = 0; n < FORLIM; n++) {
    putin('.', &V);
    WITH = &changes.data[n];
    switch (WITH->changetype) {

    case 'c':
      putin(WITH->baseold, &V);
      putnumber((double)WITH->basecoo1, &V);
      putin(WITH->basenew, &V);
      break;

    case 'i':
      putin('i', &V);
      putnumber((double)WITH->basecoo1, &V);
      putin(',', &V);
      putnumber((double)WITH->basecoo2, &V);
      /*zzz111*/
      if (WITH->insertcomplement)
	putin('~', &V);
      FORLIM1 = WITH->inserts;
      for (i = 0; i < FORLIM1; i++)
	putin(WITH->insert[i], &V);
      break;

    case 'd':
      putin('d', &V);
      putnumber((double)WITH->basecoo1, &V);
      putin(',', &V);
      putnumber((double)WITH->basecoo2, &V);
      break;
    }
  }
}

Local Void putinline(pie, c_, LINK)
piece **pie;
Char c_;
struct LOC_readinstruction *LINK;
{
  /* put c onto the end of the full name of pie */
  line *WITH;

  WITH = (*pie)->key.hea.fulnam;
  if (WITH->length < linelength) {
    WITH->length++;
    WITH->letters[WITH->length - 1] = c_;
  }
}

Local Void putnumline(pie, r, LINK)
piece **pie;
double r;
struct LOC_readinstruction *LINK;
{
  /* put a number onto the end of the full name of pie */
  Char c_;   /* a character in the number */
  long n;   /* index to the characters in number */
  long i;   /* round of r */

  i = (long)floor(r + 0.5);
  for (n = numbersize(i, LINK) - 1; n >= 0; n--) {
    c_ = numberdigit(i, n, LINK);
    /*
writeln(output,'i=',i);
writeln(output,'c=',c);
writeln(output,'n=',n);
*/
    if (c_ != '+')
      putinline(pie, c_, LINK);
  }
}

Local Void linechangeset(pie, changes, LINK)
piece **pie;
changeset changes;
struct LOC_readinstruction *LINK;
{
  /* put the changeset into the piece fulnam */
  long i;   /* index to insertion */
  long n;   /* index to changes */
  long FORLIM;
  changedata *WITH;
  long FORLIM1;

  FORLIM = changes.number;
  for (n = 1; n <= FORLIM; n++) {
    if (n > 1) {
      putinline(pie, ',', LINK);
      putinline(pie, ' ', LINK);
    }
    WITH = &changes.data[n-1];
    switch (WITH->changetype) {

    case 'c':
      putinline(pie, 'a', LINK);
      putinline(pie, 't', LINK);
      putinline(pie, ' ', LINK);
      putnumline(pie, (double)WITH->basecoo1, LINK);
      putinline(pie, ' ', LINK);
      putinline(pie, WITH->baseold, LINK);
      putinline(pie, '-', LINK);
      putinline(pie, '>', LINK);
      putinline(pie, WITH->basenew, LINK);
      break;

    case 'i':
      putinline(pie, 'i', LINK);
      putinline(pie, 'n', LINK);
      putinline(pie, 's', LINK);
      putinline(pie, 'e', LINK);
      putinline(pie, 'r', LINK);
      putinline(pie, 't', LINK);
      putinline(pie, ' ', LINK);
      if (WITH->insertcomplement)
	putinline(pie, '~', LINK);
      if (WITH->inserts > 0) {
	FORLIM1 = WITH->inserts;
	for (i = 0; i < FORLIM1; i++)
	  putinline(pie, WITH->insert[i], LINK);
      } else {
	putinline(pie, 'N', LINK);   /* NOTHING */
	putinline(pie, 'O', LINK);
	putinline(pie, 'T', LINK);
	putinline(pie, 'H', LINK);
	putinline(pie, 'I', LINK);
	putinline(pie, 'N', LINK);
	putinline(pie, 'G', LINK);
      }
      putinline(pie, ' ', LINK);
      putinline(pie, 'b', LINK);
      putinline(pie, 'e', LINK);
      putinline(pie, 't', LINK);
      putinline(pie, 'w', LINK);
      putinline(pie, 'e', LINK);
      putinline(pie, 'e', LINK);
      putinline(pie, 'n', LINK);
      putinline(pie, ' ', LINK);
      putnumline(pie, (double)WITH->basecoo1, LINK);
      putinline(pie, ' ', LINK);
      putinline(pie, 'a', LINK);
      putinline(pie, 'n', LINK);
      putinline(pie, 'd', LINK);
      putinline(pie, ' ', LINK);
      putnumline(pie, (double)WITH->basecoo2, LINK);
      break;

    case 'd':
      putinline(pie, 'd', LINK);
      putinline(pie, 'e', LINK);
      putinline(pie, 'l', LINK);
      putinline(pie, 'e', LINK);
      putinline(pie, 't', LINK);
      putinline(pie, 'e', LINK);
      putinline(pie, ' ', LINK);
      putnumline(pie, (double)WITH->basecoo1, LINK);
      putinline(pie, ' ', LINK);
      putinline(pie, 't', LINK);
      putinline(pie, 'o', LINK);
      putinline(pie, ' ', LINK);
      putnumline(pie, (double)WITH->basecoo2, LINK);
      break;
    }
  }
}  /* linechangeset */

Local boolean realbetween(a_, b, c_, LINK)
double a_, b, c_;
struct LOC_readinstruction *LINK;
{
  /* is b between a and c? */
  /* this is an inclusive between */
  return (a_ <= b && b <= c_ || c_ <= b && b <= a_);
}

/* Local variables for checkoneoverlap: */
struct LOC_checkoneoverlap {
  struct LOC_readinstruction *LINK;
  changeset c_;
} ;

Local Void setrange(n, first, last, LINK)
long n;
double *first, *last;
struct LOC_checkoneoverlap *LINK;
{
  /* Determine the range (first to last) for then nth change, adjusting
it so that insertions are for the region affected, just like deletions
and changes. */
  changedata *WITH;

  WITH = &LINK->c_.data[n-1];
  /*
; writeln(output,'first = ',first:1);
; writeln(output,'last  = ',last :1);
*/
  *first = WITH->internal1;
  *last = WITH->internal2;
  if (WITH->changetype != 'i')
    return;
  if (*first + 1 == *last) {
    *first += 0.5;
    *last -= 0.5;
  } else {
    (*first)++;
    (*last)--;
  }
}  /* setrange */

Local Void checkoneoverlap(c__, x, LINK)
changeset c__;
long x;
struct LOC_readinstruction *LINK;
{
  /* check that one overlap in the changeset c does not
overlap any other changes. */
  struct LOC_checkoneoverlap V;
  long y;   /* another change */
  double x1, x2;   /* internal coordinates for x */
  double y1, y2;   /* internal coordinates for x */
  _TEXT TEMP;

  V.LINK = LINK;
  V.c_ = c__;
  /*
write(output,'checkoverlap: ');
writechangeset(output,c);
writeln(output);
*/
  /*
writeln(output,'checkoverlap: x = ',x:1);
*/
  setrange(x, &x1, &x2, &V);
  for (y = 0; y <= x - 2; y++) {
    /*
writeln(output,'checkoverlap:       y=',y:1);
*/
    setrange(y + 1, &y1, &y2, &V);
    if (realbetween(x1, y1, x2, LINK) | realbetween(x1, y2, x2, LINK)) {
      /*EEE*/
      mutcd1 = V.c_.data[x-1];
      mutcd2 = V.c_.data[y];
      printf("In ");
      TEMP.f = stdout;
      *TEMP.name = '\0';
      writechangeset(&TEMP, V.c_);
      putchar(' ');
      TEMP.f = stdout;
      *TEMP.name = '\0';
      wchangedata(&TEMP, V.c_.data[x-1]);
      printf(" overlaps ");
      TEMP.f = stdout;
      *TEMP.name = '\0';
      wchangedata(&TEMP, V.c_.data[y]);
      putchar('\n');
      error(222L, LINK->LINK);
    }
    /*zzzppp*/
  }
}

Local Void changesequence(changes, thesequence, coordinateside, deleted, LINK)
changeset changes;
piece **thesequence;
direction coordinateside;
boolean *deleted;
struct LOC_readinstruction *LINK;
{
  /* Make changes to the sequence.  Setinternal must be called prior to this
procedure to set up the internal variables used.  Account for the rule in
libdef that inserts have the direction as the coordinate system.
Change the coordinate system on the coordinate side given.
If the sequence was deleted by mutation(s), set deleted true.
*/
  long b1, b2;
  /* internal coordinate values for the basecoo1 and
                      basecoo2 of the changeset */
  long deletes;   /* amount to delete the sequence */
  long i;   /* counter for inserts */
  long n;   /* counter for the changes */
  long shift;   /* amount to shift a portion of the sequence */
  long pielength;   /* current length of the piece */
  long FORLIM;
  changedata *WITH;
  _TEXT TEMP;
  long FORLIM1;

  /*
writeln(marksdelila,'*4**************************************************');
write(marksdelila,'* SSSSSSSSSSS changesequence: ');
write(marksdelila,'* change: ');
writechangeset(marksdelila,changes);
writeln(marksdelila);
*/
  namechangeset(thesequence, changes, LINK);
  pielength = piecelength(*thesequence);
  /*
     checkoverlap(changes, thesequence);
  */
  *deleted = false;

  FORLIM = changes.number;
  /* First check that the c-type changes match the sequence.  In the new
     scheme, this is done against the normal sequence.  Since propagation is
     done in the next loop, thesequence changes, so it can't be done there.
     */


  for (n = 1; n <= FORLIM; n++) {
    WITH = &changes.data[n-1];

    checkoneoverlap(changes, n, LINK);
    b1 = WITH->internal1;
    b2 = WITH->internal2;

    switch (WITH->changetype) {

    case 'c':
      if (WITH->baseold == WITH->basenew) {
	printf("You wrote ");
	TEMP.f = stdout;
	*TEMP.name = '\0';
	writechangeset(&TEMP, changes);
	printf(" \n");
	printf("but the initial and final bases are the same,\n");
	printf("so you did not request any change!\n");
	error(214L, LINK->LINK);
	geteoinst(LINK);
      } else {
	if ((*thesequence)->key.coodir != (*thesequence)->key.piedir) {
	  /* AaaHa!  They are working on the complementary strand,
	     so switch around and complement the bases!! */
	  /*
write  (marksdelila,'*   switching baseold and basenew:');
write  (marksdelila,'* baseold = ',baseold);
writeln(marksdelila,'* basenew = ',basenew);
*/
	  WITH->baseold = basetochar(complement(chartobase(WITH->baseold)));
	  WITH->basenew = basetochar(complement(chartobase(WITH->basenew)));
	  /*
write  (marksdelila,'* switched baseold and basenew to:');
write  (marksdelila,'* baseold = ',baseold);
writeln(marksdelila,'* basenew = ',basenew);
*/
	}
	if (b1 < 1) {
	  printf(
	    "A requested mutation coordinate is off the piece in the 5' direction\n");
	  mutposition1 = WITH->basecoo1;   /* mutation position */
	  error(215L, LINK->LINK);
	  geteoinst(LINK);
	} else if (b1 > pielength) {
	  printf(
	    "A mutation requested coordinate is off the piece in the 3' direction\n");
	  mutposition1 = WITH->basecoo1;   /* mutation position */
	  error(216L, LINK->LINK);
	  geteoinst(LINK);
	} else if (WITH->baseold != getbasech(b1, *thesequence, LINK)) {
	  /* it must be a wrong base */
	  mutposition1 = WITH->basecoo1;   /* mutation position */
	  mutnotchar = WITH->baseold;   /* what mutation is not */
	  mutischar = getbasech(b1, *thesequence, LINK);
	      /* what mutation is */
	  if ((*thesequence)->key.coodir != (*thesequence)->key.piedir) {
	    /* AaaHa!  They are working on the complementary strand,
	       so switch around and complement the bases!! */
	    /*
write  (marksdelila,'*   switching baseold and basenew:');
write  (marksdelila,'* baseold = ',baseold);
writeln(marksdelila,'* basenew = ',basenew);
*/
	    WITH->baseold = chomplement(WITH->baseold);
	    WITH->basenew = chomplement(WITH->basenew);
	    mutischar = chomplement(mutischar);
	    mutnotchar = chomplement(mutnotchar);
	    /*
write  (marksdelila,'* switched baseold and basenew to:');
write  (marksdelila,'* baseold = ',baseold);
writeln(marksdelila,'* basenew = ',basenew);
*/
	  }
	  printf(
	    "On the positively oriented strand, the old base at %ld is NOT %c!  It is %c.\n",
	    WITH->basecoo1, WITH->baseold, mutischar);
	  /* mutation: old base is not correctly identified */
	  error(211L, LINK->LINK);
	  geteoinst(LINK);
	}
      }
      break;

    case 'i':   /* no checks here at this time */
      break;

    case 'd':   /* no checks here at this time */
      break;
    }
  }
  FORLIM = changes.number;
  /* make changes to thesequence and propagate them one by one in the
     changes changeset. */
  /*
write(marksdelila,'* EEEEEEEEEE, changesequence: ');
writechangeset(marksdelila,changes);
writeln(marksdelila);
writeln(output,'END OF changesequence:');
bwpie(output, thesequence);
*/
  /*zzzyyy*/
  for (n = 1; n <= FORLIM; n++) {
    WITH = &changes.data[n-1];
    /*zzzyyy*/
    /*
writeln(output,'* changeloop n= ',n:1,'------------------------------');
writeln(marksdelila,'* changesequence: basecoo1 = ',basecoo1:1);
writeln(marksdelila,'* changesequence: basecoo2 = ',basecoo2:1);
writeln(marksdelila,'* changesequence: internal1 = ',internal1:1,' old');
writeln(marksdelila,'* changesequence: internal2 = ',internal2:1,' old');
writeln(marksdelila,'* changesequence: within(thesequence,basecoo1) = ',
                                           within(thesequence,basecoo1):1);
writeln(marksdelila,'* changesequence: within(thesequence,basecoo2) = ',
                                           within(thesequence,basecoo2):1);
    */

    b1 = WITH->internal1;
    b2 = WITH->internal2;

    switch (WITH->changetype) {

    case 'c':
      if (b1 < 1 || b2 > pielength)
	error(219L, LINK->LINK);
      else
	putbasech(WITH->basenew, b1, *thesequence, coordinateside, LINK);
      break;

    case 'i':
      if (b1 < 0 && b2 > pielength && WITH->inserts == 0) {
	error(220L, LINK->LINK);
	/* 2005 Sep 6 */
	geteoinst(LINK);
	*deleted = true;

      } else {
	/*
writeln(output,'start of insert: b1= ',b1:1,' b2= ',b2:1);
*/
	/* make sure insertion is at the end of the piece */
	if (b1 > pielength)
	  b1 = pielength;
	if (b2 > pielength)
	  b2 = pielength + 1;
	if (b1 < 0)
	  b1 = 0;
	if (b2 < 1)   /* original */
	  b2 = 1;
	/*
writeln(output,'after correction: b1= ',b1:1,' b2= ',b2:1);
*/

	if (b1 == b2) {
	  printf(
	    " The first base, %ld, must not equal  the second base, %ld for insertion\n",
	    WITH->basecoo1, WITH->basecoo2);

	  mutposition1 = WITH->basecoo1;   /* mutation position */
	  mutposition2 = WITH->basecoo2;   /* mutation position */
	  error(218L, LINK->LINK);
	  geteoinst(LINK);
	}

	deletes = b2 - b1 - 1;
	shift = WITH->inserts - deletes;
	pielength += shift;
	/*
writeln(marksdelila,'* changesequence: inserts= ',inserts:1);
writeln(marksdelila,'* changesequence: shift= ',shift:1);
writeln(marksdelila,'* changesequence: new pielength= ',pielength:1);
*/

	if (shift > 0) {  /* insert */
	  switch ((*thesequence)->key.piedir) {

	  case plus:
	    if (b2 - shift < 1)
	      b2 += shift;
	    break;

	  case minus:
	    if (b2 - shift < 1)
	      b2 += shift;
	    break;
	  }

	  /*
if thesequence^.key.piedir = plus then writeln(output,'PLUS')
	                                    else writeln(output,'MINUS');
	  */

	  /*
zzzyyy
writeln(output,'basecoo1= ',basecoo1:4:1);
writeln(output,'basecoo2= ',basecoo2:4:1);
writeln(output,'new b2= ',b2:1);
writeln(output,'b1= ',b1:1);
writeln(output);
writeln(output,'BEFORE:');
bwpie(output, thesequence);
writeln(output,'-- pielength= ',pielength:1); (* the NEW piece length *)
	                       (* piecelength will be the actual length after the first
	                          insert *)
	  */

	  /*zzzCCC*/
	  for (i = pielength; i >= b2; i--)
	    putbasech(getbasech(i - shift, *thesequence, LINK), i,
		      *thesequence, coordinateside, LINK);

	  /*
writeln(output,'AFTER:');
bwpie(output, thesequence);
for i := pielength downto b2
do write(output,getbasech(i-shift,thesequence));
writeln(output);
*/
	  /*zzznnn*/

	  /*
writeln(output);
writeln(output,'AFTER');
bwpie(output, thesequence);
*/

	  /*
(* wrecking: *)
for i := pielength downto b2
do putbasech('g', i,thesequence,coordinateside);

for i := 2 to pielength
do putbasech('g', i,thesequence,coordinateside);

writeln(output);
writeln(output,'AFTER WRECKING');
bwpie(output, thesequence);
*/


	}
	/*
writeln(marksdelila,'* changesequence: INSERTION');
*/
	/* shift the rest of the sequence out of the way */
	/* if insertion is at the 5' end, don't try to grab base
	   off the end! */
	/*
writeln(output,'old b2= ',b2:1);
writeln(output,'shift= ',shift:1);
*/

	else if (shift < 0) {  /* delete */
	  /*
writeln(marksdelila,'* changesequence: insert type DELETION');
writeln(marksdelila,'* BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB');
writeln(marksdelila,'* shift < 0 in changesequence');
writeln(marksdelila,'* basecoo1= ',basecoo1:4:1);
writeln(marksdelila,'* basecoo2= ',basecoo2:4:1);
writeln(marksdelila,'* new b2= ',b2:1);
writeln(marksdelila,'* b1= ',b1:1);
writeln(marksdelila);
*/
	  /*
writeln(output,'BEFORE:');
bwpie(output, thesequence);
*/
	  /*BBB*/

	  for (i = b2 + shift; i <= pielength; i++) {
	    putbasech(getbasech(i - shift, *thesequence, LINK), i,
		      *thesequence, coordinateside, LINK);

	  }
	  /* shift < 0 so to make deletion, take the positive: */
	  fixpiececoordinate(thesequence, shift, coordinateside, LINK);

	  /*
writeln(output,'AFTER:');
bwpie(output, thesequence);
writeln(output,'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA');
*/

	  if (shift < 0)
	    compress(thesequence, LINK);
	} else {
	  if (WITH->inserts == 0) {
	    /*EEE*/
	    error(219L, LINK->LINK);
	    /* shift = 0 */
	  }
	}

	/*
writeln(output);

if not (thesequence^.key.coodir = thesequence^.key.piedir)
then write(output,'* NOT')
else write(output,'*    ');
writeln(output,' (thesequence^.key.coodir = thesequence^.key.piedir)');

if not insertcomplement
then write(output,'* NOT')
else write(output,'*    ');
writeln(output,' insertcomplement');
*/

	/* insert the new material */
	/* account for the rule that the insert has the
	   same orientation as the coordinate system.
	Let same := (thesequence^.key.coodir = thesequence^.key.piedir);
	Then there are 4 cases:
	                 insertcomplement
	               false          true
	same  true     Homologous     Complement
	same  false    Complement     Homologous

	This logic can be done by testing that the booleans are
	equal or not (thanks to Karen Lewis for this suggestion!): */
	if (((*thesequence)->key.coodir == (*thesequence)->key.piedir) !=
	    WITH->insertcomplement)
	{  /* HOMOLOGOUS case */
	  FORLIM1 = WITH->inserts;
	  for (i = 1; i <= FORLIM1; i++)
	    putbasech(WITH->insert[i-1], b1 + i, *thesequence, coordinateside,
		      LINK);
	  /*
writeln(output,'* changesequence: EQUAL => HOMOLOGOUS');
writeln(marksdelila,'* changesequence: EQUAL => HOMOLOGOUS');
*/
	}
	/*zzz111*/
	else {
	  FORLIM1 = WITH->inserts;
	  for (i = 1; i <= FORLIM1; i++) {   /* reverse insertion order! */
	    putbasech(chomplement(WITH->insert[i-1]),
		      b1 + WITH->inserts - i + 1, *thesequence,
		      coordinateside, LINK);
	    /* COMPLEMENT case */

	    /*
writeln(output);
writeln(output,'piecelength(thesequence)=',piecelength(thesequence):1);
writeln(output,'AFTER INSERTION');
bwpie(output, thesequence);
*/

	  }
	  /* the order of insertion doesn't matter.
	     What counts here is that the bases be put
	     in in reverse position.
	     This solves the bug of 2000 May 25
	     where inserts were not reversed */

	  /*
writeln(output,'* changesequence: FLIP => COMPLEMENT');
writeln(marksdelila,'* changesequence: FLIP => COMPLEMENT');
*/
	}
      }
      break;

    case 'd':  /* delete inclusively from b1 to b2 */
      if (b1 <= 1 && b2 >= pielength) {
	error(220L, LINK->LINK);
	/* 2005 Sep 6 */
	geteoinst(LINK);
	*deleted = true;
      } else if (b1 > pielength && b2 > pielength || b1 < 1 && b2 < 1) {
	/* b1 and b2 were both off the same end, consider
	   shifting the piece coordinates. */
	error(221L, LINK->LINK);
	/*
writeln(output,'changesequence: delete: b1 = ',b1:1);
writeln(output,'changesequence: delete: b2 = ',b2:1);
writeln(output,'changesequence: delete: shift = ',shift:1);
*/
	/* Not implemented: see notes in shiftpiececoordinate Sss
	                  if (coordinateside = minus) and
	                     ((b1 >= pielength) and (b2 >= pielength))
	                  then begin
	                     shiftpiececoordinate(thesequence, basecoo1, basecoo2, minus);
	                  end
	                  else if (coordinateside = plus) and
	                          ((b1 <= 1) and (b2 <= 1))
	                  then begin
	                     shiftpiececoordinate(thesequence, basecoo1, basecoo2, plus);
	                  end
	                  (* otherwise don't do the shift *)
	*/
      }

      else {
	if (b1 < 1)
	  b1 = 1;
	if (b2 < 1)
	  b2 = 1;
	if (b1 > pielength)
	  b1 = pielength;
	if (b2 > pielength)
	  b2 = pielength;
	/*
writeln(output,'changesequence: delete: b1 = ',b1:1);
writeln(output,'changesequence: delete: b2 = ',b2:1);
*/

	shift = b2 - b1 + 1;

	pielength -= shift;
	for (i = b1; i <= pielength; i++)
	  putbasech(getbasech(i + shift, *thesequence, LINK), i, *thesequence,
		    coordinateside, LINK);

	/* account for length change */
	/* shift > 0 so to make deletion, take the negative: */
	fixpiececoordinate(thesequence, -shift, coordinateside, LINK);
	/*zzzyyy*/
	/*
writeln(output,'BEFORE compress:');
bwpie(output, thesequence);
halt;
*/
	if (shift > 0)
	  compress(thesequence, LINK);
	/*
writeln(output,'AFTER compress:');
bwpie(output, thesequence);
*/
      }
      break;
      /*DDD*/
      /*
writeln(output,'changesequence: delete: basecoo1 = ',basecoo1:1);
writeln(output,'changesequence: delete: basecoo2 = ',basecoo2:1);
writeln(output,'changesequence: delete: b1 = ',b1:1);
writeln(output,'changesequence: delete: b2 = ',b2:1);
*/

    }
    /*zzzppp*/
    /*
writeln(output);
writeln(output,'changesequence: about to propagateonechange, n = ',n:1);
*/
    propagateonechange(&changes, n, *thesequence, LINK);
    /*
write(output,'changesequence: changes  = ');
writechangeset(output,changes);
writeln(output);
*/
  }
}  /* changesequence */

/* Local variables for extractpiece: */
struct LOC_extractpiece {
  struct LOC_readinstruction *LINK;
  piece *libpie, **pie;
  long cutposition;
  boolean reversing;   /* if true reverse the dna */
  boolean acrossboundary;
  /* request is across the boundary
                               of a circular dna */
  /* the direction of the piece of dna being read is
     positive with respect to its coordinate system: */
  long startread, stopread;   /* range of bases to read in the library */
} ;

Local Void setvariables(LINK)
struct LOC_extractpiece *LINK;
{
  /* set up variables */
  /* we will complement if the direction was changed */
  LINK->reversing = ((*LINK->pie)->key.piedir != LINK->libpie->key.piedir);

  /* figure out acrossboundary: */
  if ((*LINK->pie)->key.coocon == circular &&
      (*LINK->pie)->key.piecon == linear)
    LINK->acrossboundary = within(*LINK->pie, LINK->libpie->key.piebeg) &
			   within(*LINK->pie, LINK->libpie->key.pieend);
  else
    LINK->acrossboundary = false;

  /* acrossboundary may not be right yet, since we must handle the
  special case where we want a linearized form of the
  circle: the piece and library piece ends will be
  the same, so we want to do case 1, not case 3 */
  if (LINK->acrossboundary) {
    if (LINK->reversing) {
      if (LINK->libpie->key.piebeg == (*LINK->pie)->key.pieend &&
	  LINK->libpie->key.pieend == (*LINK->pie)->key.piebeg)
	LINK->acrossboundary = false;
    } else {
      if (LINK->libpie->key.piebeg == (*LINK->pie)->key.piebeg &&
	  LINK->libpie->key.pieend == (*LINK->pie)->key.pieend)
	LINK->acrossboundary = false;
    }
  }

  /* get first dna */
  getdna(&(*LINK->pie)->dna);

  /*
writeln(output,'setvariables:');
writeln(output,'acrossboundary is ', acrossboundary);
writeln(output,'pie^.key.piecon is ', pie^.key.piecon);
writeln(output,'pk^.key.piecon is ', pk^.key.piecon);
writeln(output,'libpie^.key.piecon is ', libpie^.key.piecon);
*/
}

Local Void case1(LINK)
struct LOC_extractpiece *LINK;
{
  if (debugging)
    fprintf(debug.f, "case1\n");
  /*
writeln(output,'==== BEG case1');
*/
  LINK->startread = pietoint((*LINK->pie)->key.piebeg, LINK->libpie);
  LINK->stopread = pietoint((*LINK->pie)->key.pieend, LINK->libpie);
  /*
writeln(output,'pie^.key.piebeg = ', pie^.key.piebeg:1,' TAG');
writeln(output,'pie^.key.pieend = ', pie^.key.pieend:1,' TAG');
writeln(output,'startread = ',startread:1);
writeln(output,' stopread = ',stopread:1);
writeln(output,'case1: reversing = ',reversing);
*/
  circledna(LINK->libpie, LINK->pie, LINK->startread, LINK->stopread,
	    LINK->reversing, LINK->LINK);
}

Local Void case2(LINK)
struct LOC_extractpiece *LINK;
{
  /*
circular in library --> circular request --> case 2
*/
  if (debugging)
    fprintf(debug.f, "case2\n");
  /*
writeln(output,'case2');
*/
  if (LINK->reversing) {
    LINK->startread = pietoint(LINK->cutposition, LINK->libpie);
    if (LINK->startread < piecelength(LINK->libpie))
      LINK->stopread = LINK->startread + 1;
    else
      LINK->stopread = 1;
    circledna(LINK->libpie, LINK->pie, LINK->startread, LINK->stopread,
	      LINK->reversing, LINK->LINK);
    return;
  }
  LINK->startread = pietoint(LINK->cutposition, LINK->libpie);
  if (LINK->startread > 1)
    LINK->stopread = LINK->startread - 1;
  else
    LINK->stopread = piecelength(LINK->libpie);
  circledna(LINK->libpie, LINK->pie, LINK->startread, LINK->stopread,
	    LINK->reversing, LINK->LINK);
}

Local Void case3(LINK)
struct LOC_extractpiece *LINK;
{
  /*
circular in library --> linear request --> across boundary --> case 3
*/
  if (debugging)
    fprintf(debug.f, "case3\n");
  /*
writeln(output,'case3');
*/
  LINK->startread = pietoint((*LINK->pie)->key.piebeg, LINK->libpie);
  LINK->stopread = pietoint((*LINK->pie)->key.pieend, LINK->libpie);
  circledna(LINK->libpie, LINK->pie, LINK->startread, LINK->stopread,
	    LINK->reversing, LINK->LINK);
}

Local Void extractpiece(libpie_, pie_, cutposition_, LINK)
piece *libpie_, **pie_;
long cutposition_;
struct LOC_readinstruction *LINK;
{
  /*; not implemented
                         var markers: markerptr*/
  /* extract the piece pie from the libpie */
  /* formerly: lrpiedna, library read piece dna */
  /* at the onset, the reading point is just before the first base of
the piece.
     there are three major cases for reading in the dna.
case 1. a. this is the simplest.  a linear piece in the library can only
have a linear fragment in the book.  action:
        skip to the start of the region of interest.
        read the dna.
case 1. b. a circle of dna is stored linearly in the library (and
labeled 'circular').  if one wants a fragment of a circle and the
fragment lies completely within the stored dna, then one still can
apply case 1.

case 2. one wants all of a circular sequence.  one just reads the whole
dna, and breaks at the requested cut point.

case 3. this is the most complicated.  one wants a linear fragment of a
circle, but the fragment happens to lie across the boundary cut by storing
the sequence linearly in the library (acrossboundary). (in case 1b, it
could not lie across the boundary since its parent is linear.)  one must:
        read from the piece beginning base to the stop of the fragment.
        skip around to the start of the fragment.
        read up to the piece ending base.
        fuse the two fragments into the final product.

linear in library --> linear request --> case 1
or
circular in library --> circular request --> case 2
                          or
                          linear request --> across boundary --> case 3
                                             or
                                             not across boundary --> case 1
  */
  struct LOC_extractpiece V;

  V.LINK = LINK;
  /*
writeln(output,'OUT extractpiece');
*/
  V.libpie = libpie_;
  V.pie = pie_;
  V.cutposition = cutposition_;
  /*
writeln(output,'BEGIN extractpiece');
writeln(output,'pie^.key.piecon is ', pie^.key.piecon);
writeln(output,'pk^.key.piecon is ', pk^.key.piecon);
writeln(output,'libpie^.key.piecon is ', libpie^.key.piecon);
*/
  setvariables(&V);
  if (V.acrossboundary) {
    case3(&V);
    return;
  }
  if ((*V.pie)->key.piecon == linear)
    case1(&V);
  else
    case2(&V);
}  /* extractpiece */

Local Void gozero(Apiece, LINK)
piece **Apiece;
struct LOC_readinstruction *LINK;
{
  /* Transform a piece to a zero coordinate system. */
  if (def.coo != coorzero)
    return;
  (*Apiece)->key.coocon = linear;
  (*Apiece)->key.coodir = plus;
  switch ((*Apiece)->key.piedir) {

  case plus:
    zeroBS = zerobase - zeroshift;
    (*Apiece)->key.coobeg = (*Apiece)->key.piebeg - zeroBS;
    (*Apiece)->key.cooend = (*Apiece)->key.pieend - zeroBS;
    (*Apiece)->key.piecon = linear;
    (*Apiece)->key.piedir = plus;
    (*Apiece)->key.piebeg -= zeroBS;
    (*Apiece)->key.pieend -= zeroBS;
    break;

  case minus:
    zeroBS = zerobase + zeroshift;
    (*Apiece)->key.coobeg = zeroBS - (*Apiece)->key.piebeg;
    (*Apiece)->key.cooend = zeroBS - (*Apiece)->key.pieend;
    (*Apiece)->key.piecon = linear;
    (*Apiece)->key.piedir = plus;
    (*Apiece)->key.piebeg = zeroBS - (*Apiece)->key.piebeg;
    (*Apiece)->key.pieend = zeroBS - (*Apiece)->key.pieend;
    break;
  }
}

/**************************************************************************/
/**************************************************************************/

Local Void addnumber(hea, n, LINK)
header *hea;
long n;
struct LOC_readinstruction *LINK;
{
  /* add a number n to the header */
  /* numbers are rounded to this precision.  There
     was a bug on a Sun 4, where the 1000th piece was labeled 000
     because of truncation.  */
  line *numbernote;
  /* the number of this item, for insertion
     into the notes of the header */
  long signspace;
  /* the number of spaces reserved for the
                         sign of the number */
  long numdigits;   /* number of digits in the number */
  long digit;   /* a digit */
  long index;
  Char charnum;
  line *noteindex;   /* used to scan the header note */

  getline(&numbernote);

  for (index = 0; index < numberlength; index++)
    numbernote->letters[index] = LINK->LINK->numberword[index];
  if (n < 0) {  /* handle negative sign */
    numbernote->letters[numberlength] = '-';
    signspace = 1;
    n = -n;
  } else
    signspace = 0;
  /* for positive n */
  if (n == 0) {
    numdigits = 1;
    /* old form that caused the bug:
                 else numdigits:=trunc(ln(n)/ln(10)+1); */
    /* the new form that avoids the bug by causing rounding from point precision */
  } else
    numdigits = (long)(log((double)n) / log(10.0) + 1 + precision);

  numbernote->length = numberlength + signspace + numdigits;
  for (index = numbernote->length - 1; index >= numberlength + signspace; index--) {
    digit = n % 10;
/* p2c: delila.p, line 8431:
 * Note: Using % for possibly-negative arguments [317] */
    n /= 10;
    switch (digit) {

    case 0:
      charnum = '0';
      break;

    case 1:
      charnum = '1';
      break;

    case 2:
      charnum = '2';
      break;

    case 3:
      charnum = '3';
      break;

    case 4:
      charnum = '4';
      break;

    case 5:
      charnum = '5';
      break;

    case 6:
      charnum = '6';
      break;

    case 7:
      charnum = '7';
      break;

    case 8:
      charnum = '8';
      break;

    case 9:
      charnum = '9';
      break;
    }
    numbernote->letters[index] = charnum;
  }
  /* insert number before the other notes */
  numbernote->next = hea->note;   /* end of number points to header */
  hea->note = numbernote;   /* header starts with the number */
  /* insert user notes below the other notes */
  if (LINK->LINK->usernotes == NULL)
    return;
  if (hea->note != NULL) {
    /* point to first note */
    noteindex = hea->note;

    /* look for last note */
    while (noteindex->next != NULL)
      noteindex = noteindex->next;

    /* link user notes to end of last header note */
    noteindex->next = LINK->LINK->usernotes;
  } else
    hea->note = LINK->LINK->usernotes;

  /* clear usernotes */
  LINK->LINK->usernotes = NULL;
}

#undef precision

/* specification */
Local Void spec(hea, numberable, object, LINK)
header *hea;
state numberable;
double *object;
struct LOC_readinstruction *LINK;
{
  /* specify the object and maybe give it a number and the current usernotes */
  /* if library notes are off, then destroy them */
  if (def.key.note == off) {
    while (hea->note != NULL)
      clearline(&hea->note);
  }

  if (numberable == on) {
    def.num.item++;
    *object = def.num.item;
    ivaluenumber((long)(*object), LINK->LINK);
  } else
    *object = -0.5;
  /* specified but not numbered */

  if (def.num.sta == on && numberable == on)
	/* insert a number into the object"s note */
	  addnumber(hea, def.num.item, LINK);
}

Local Void specified(object, LINK)
double object;
struct LOC_readinstruction *LINK;
{
  /* was this object specified? */
  LINK->LINK->correct = (object != 0.5);
}

Local boolean numbered_(object, LINK)
double object;
struct LOC_readinstruction *LINK;
{
  /* determine if this object was numbered */
  return (fabs(object) != 0.5);
}

Local Void specpiece(ref, LINK)
reference ref;
struct LOC_readinstruction *LINK;
{
  /* specify the piece referred to if it is not currently specified.
2001 Mar 16: read in the LIBRARY piece, libpie */
  specified(LINK->LINK->pkspec, LINK);
  if (!LINK->LINK->correct ||
      strncmp(ref.pienam.letters, LINK->LINK->pk->key.hea.keynam.letters,
	      sizeof(alpha)))
    lrpiece(ref.pienam, &libpie);
  /* the piece will become specified, but we do not want to give it a
     number until we get to the request */
  LINK->LINK->pkspec = -0.5;
}

Local Void unspec(object, LINK)
double *object;
struct LOC_readinstruction *LINK;
{
  /* unspecify this object */
  *object = 0.5;
}

Local Void unspecbelowck(LINK)
struct LOC_readinstruction *LINK;
{
  /* unspecify the objects below ck */
  unspec(&LINK->LINK->mkspec, LINK);
  unspec(&LINK->LINK->tkspec, LINK);
  unspec(&LINK->LINK->gkspec, LINK);
  unspec(&LINK->LINK->pkspec, LINK);
}

/**************************************************************************/
/**************************************************************************/

Local Void checksize(pk, LINK)
piece *pk;
struct LOC_readinstruction *LINK;
{
  /* check that the size of the piece pk added to previous
pieces would not exceed maxbook. */
  booksize += piecelength(pk);
  if (booksize <= maxbook)
    return;
  booksize = 0;   /* count of bases */
  LINK->LINK->getcount = 0;   /* count of pieces */
  error(223L, LINK->LINK);
  geteoinst(LINK);
}

/*
   sortedmutations: changeset; (* the mutations but sorted for printing *)
*/

Local long dirvalue(d)
direction d;
{
  /* convert a direction to a +1 or a -1 value */
  long Result;

  switch (d) {

  case plus:
    Result = 1;
    break;

  case minus:
    Result = -1;
    break;

  case dirhomologous:
    Result = 0;
    break;

  case dircomplement:
    Result = 0;
    break;
  }
  return Result;
}

Local long sign_(thetimes)
long thetimes;
{
  /* find the sign of the times */
  if (thetimes >= 0)
    return 1;
  else
    return -1;
}

Local boolean BooleanXOR(a_, b)
boolean a_, b;
{
  /* exclusive or function */
  return (a_ && !b || b && !a_);
}

Local Void dopiece(LINK)
struct LOC_readinstruction *LINK;
{
  /* called in pass 2 only */
  /* put together a call for a piece of dna,
     using the interface to the library.  these global variables must
     be provided: fromposition, toposition,
     directionwanted (as a plus or minus value), cutposition, mkon,
     and configuration (pk^.key.piecon)
     the above variables are not modified by dopiece.

     dopiece calculates piedir, piebeg and pieend.
     modify the sequence according to the changeset.
     finally, bwpie is called.
  */
  long vdirwanted;   /* value (+1 or -1) of direction wanted */
  /* value of direction implied by fromposition */
  long vdirimplied;   /* and toposition */
  long libstart;
  /* the library coordinate boundary
                        closest to the piece begin */
  boolean deleted;   /* the sequence was deleted - don't write it out */
  piekey *WITH;

  /*
writeln(output,'dopiece-IN');
writeln(output,'pk^.key.piecon is ', pk^.key.piecon);
writeln(output,'libpie^.key.piecon is ', libpie^.key.piecon);
*/

  WITH = &LINK->LINK->pk->key;
  /* we first convert directionwanted into the vdirwanted value.
     only plus, minus values are honored. */
  /*
        if dirwanted in [plus, minus]
        then vdirwanted:=dirvalue(dirwanted)
        else vdirwanted:=dirvalue(libpie^.key.piedir);
  */
  /* 1999 mar 17:the reason for that restriction is lost in the mists of time! */

  if (((1L << ((long)LINK->LINK->dirwanted)) &
       ((1L << ((long)plus)) | (1L << ((long)minus)))) != 0)
    vdirwanted = dirvalue(LINK->LINK->dirwanted);
  else if (LINK->LINK->dirwanted == dirhomologous)
    vdirwanted = dirvalue(libpie->key.piedir);
  else
    vdirwanted = -dirvalue(libpie->key.piedir);

  /* we now calculate the direction implied
     by the from and to positions: vdirimplied */
  if (LINK->LINK->toposition == LINK->LINK->fromposition)
    vdirimplied = vdirwanted;   /* new as of 1999 mar 17!! */
  else {
    switch (WITH->coocon) {

    case linear:
      vdirimplied = sign_(LINK->LINK->toposition - LINK->LINK->fromposition);
      break;

    case circular:
      switch (libpie->key.piecon) {

      case circular:   /* can not check it */
	vdirimplied = vdirwanted;
	break;

      case linear:
	if (within(libpie, WITH->coobeg) & within(libpie, WITH->cooend))
	{  /* coord. boundary may be in the way */
	  /* take care of piece direction */
	  switch (libpie->key.piedir) {

	  case plus:
	    libstart = libpie->key.cooend;
	    break;

	  case minus:
	    libstart = libpie->key.coobeg;
	    break;
	  }
	  /* which side of the boundary
	     are the positions on?
	  if (t and not f) or (f and not t) then opposite */
	  if (BooleanXOR(between(libpie->key.piebeg, LINK->LINK->toposition,
				 libstart),
			 between(libpie->key.piebeg, LINK->LINK->fromposition,
				 libstart))) {
	    /* opposite sides: */
	    vdirimplied = -sign_(LINK->LINK->toposition - LINK->LINK->fromposition);
	    /* same sides: */
	  } else
	    vdirimplied = sign_(LINK->LINK->toposition - LINK->LINK->fromposition);
	} else
	  vdirimplied = sign_(LINK->LINK->toposition - LINK->LINK->fromposition);
	break;
      }
      break;
    }

    switch (LINK->LINK->dirwanted) {

    case plus:
    case minus:
      if (vdirwanted != vdirimplied)
	error(204L, LINK->LINK);
      break;

    case dirhomologous:
      vdirwanted = vdirimplied;
      break;

    case dircomplement:
      if (libpie->key.piecon == circular)
	vdirwanted = -vdirimplied;
      else
	error(204L, LINK->LINK);
      break;
    }
  }

  if (LINK->LINK->correct) {
    WITH->piebeg = LINK->LINK->fromposition;
    WITH->pieend = LINK->LINK->toposition;
    switch (vdirwanted) {

    case 1:
      WITH->piedir = plus;
      break;

    case -1:
      WITH->piedir = minus;
      break;
    }
    if (debugging) {
      fprintf(debug.f, "piebeg:%5ld pieend:%5ld cut:%5ld\n",
	      WITH->piebeg, WITH->pieend, LINK->LINK->cutposition);
      fprintf(debug.f, "ord(piecon)=%12d\n", (int)WITH->piecon);
      fprintf(debug.f, "ord(piedir)=%12d\n", (int)WITH->piedir);
    }

    /*
writeln(output,'piebeg:',piebeg:5,' pieend:',pieend:5,' cut:',cutposition:5);
writeln(output,'ord(piecon)=',ord(piecon));
writeln(output,'ord(piedir)=',ord(piedir));
*/

    /* start out with the library full name */
    copyline(libpie->key.hea.fulnam, &LINK->LINK->pk->key.hea.fulnam);
	/*,mkon not implemented*/

    /* manipulate the pk copy of libpie */
    extractpiece(libpie, &LINK->LINK->pk, LINK->LINK->cutposition, LINK);

    /* convert pk to zero based coordinate system if needed */
    gozero(&LINK->LINK->pk, LINK);
    /*zzzwww*/
    /*with ... get*/

    deleted = false;
    if (mutations.number > 0) {
      /* make any mutations desired */
      /* adjust the coordinate system if needed so that writemarks
         can use it.   Changesequence also changes the sequence. */
      setinternal(&mutations, LINK->LINK->pk, LINK);

      /* are we doubling? */
      if (def.doubling == on) {
	/*
write(output,'def.num.str[pienum] is ');
if def.num.str[pienum] = on
then writeln(output,'on')
else writeln(output,'off');
*/

	/* we first write out the wt sequence: */
	checksize(LINK->LINK->pk, LINK);   /* maxbook */
	bwpie(&book, LINK->LINK->pk);
	LINK->LINK->getcount++;

	/* then increment the piece number: */
	spec(&LINK->LINK->pk->key.hea, def.num.str[(long)pienum],
	     &LINK->LINK->pkspec, LINK);
      }


      if (def.doubling == on) {   /* upperbits for insertion symbol */
	writewildtypemarks(&marksdelila, mutations, insertupperbits,
			   insertlowerbits, deleteupperbits, deletelowerbits,
			   changeupperbits, changelowerbits, LINK->LINK->pk,
			   def.num.item, LINK);
	    /* the piece number */

	/* skip piece corresponding to the piece.  Note that
	   at this point, since there are mutations, withused must
	   be true so it is not necessary to test for it here. */

	skippiece(&marksdelila, LINK);
      }
      /* lowerbits for insertion symbol */
      /* upperbits for deletion symbol */
      /* lowerbits for deletion symbol */
      /* upperbits for change symbol */
      /* lowerbits for change symbol */
      /* the piece */

      changesequence(mutations, &LINK->LINK->pk, LINK->LINK->coordinateside,
		     &deleted, LINK);
      /*
writeln(output,'AFTER changesequence:');{zzzyyy}
bwpie(output, pk);{zzzyyy}
*/

      /* always write mutant marks.  This allows multiple changes for
         one wild type sequence. */
      if (!deleted)   /* upperbits for insertion symbol */
	writemutantmarks(&marksdelila, mutations, insertupperbits,
			 insertlowerbits, deleteupperbits, deletelowerbits,
			 changeupperbits, changelowerbits, LINK->LINK->pk,
			 def.num.item, LINK);
      /* lowerbits for insertion symbol */
      /* upperbits for deletion symbol */
      /* lowerbits for deletion symbol */
      /* upperbits for change symbol */
      /* lowerbits for change symbol */
      /* the piece */
      /* the piece number */

      clearline(&LINK->LINK->pk->key.hea.fulnam);   /* remove old */
      getline(&LINK->LINK->pk->key.hea.fulnam);   /* remove old */
      linechangeset(&LINK->LINK->pk, mutations, LINK);
    }


    /* if mutation(s) did not delete the entire piece, write it out */
    if (!deleted) {
      /* Put the long name into the piece from the name command.
      This will override the fulnam given if there were
      mutations.  */

      if (longnameexists) {
	copyline(longname, &LINK->LINK->pk->key.hea.fulnam);
	longnameexists = false;   /* use it only once */
      }

      /* skippiece corresponding to the piece */
      if (withused)
	skippiece(&marksdelila, LINK);


      /* output the result to the book */
      checksize(LINK->LINK->pk, LINK);   /* maxbook */
      bwpie(&book, LINK->LINK->pk);

      LINK->LINK->getcount++;

    }

    else {
      /* skippiece corresponding to the piece */
      /* (Note: when deleted is true, withused must be true,
         but check anyway ... */
      if (withused)
	skippiece(&marksdelila, LINK);
    }
  }
  if (debugging)
    fprintf(debug.f, "dopiece-out\n");
}  /* end of dopiece */

/**************************************************************************/
/**************************************************************************/
/**************************************************************************/

/* instruction reading routines *******************************************/

Local Void irdirection(LINK)
struct LOC_readinstruction *LINK;
{
  /* <direction> */
  /* read a direction into directionwanted */
  if (LINK->LINK->eoinst) {
    error(15L, LINK->LINK);
    return;
  }
  findword(LINK);
  if (!LINK->LINK->correct)
    return;
  if (LINK->LINK->chr == '-' || LINK->LINK->chr == '+') {
    /*
writeln(output,'First chr: "', chr,'"');
*/
    parse(false, LINK);
    /*
writeln(output,'after parse: parsedword[1]: "', parsedword[1],'"');
writeln(output,'after parse: parsedword[2]: "', parsedword[2],'"');
*/

    if (!LINK->LINK->correct)
      return;
    if (LINK->LINK->parsedword[1] != ' ') {
      error(2L, LINK->LINK);
      return;
    }
    switch (LINK->LINK->parsedword[0]) {

    case '+':
      LINK->LINK->dirwanted = plus;
      break;

    case '-':
      LINK->LINK->dirwanted = minus;
      break;

    case ' ':
      printf("irdirection: Delila parse fault\n");
      printf(" chr: \"%c\"\n", LINK->LINK->chr);
      printf(" parsedword[1]: \"%c\"\n", LINK->LINK->parsedword[0]);
      printf(" parsedword[2]: \"%c\"\n", LINK->LINK->parsedword[1]);
      /*zzzfff*/
      halt();
      break;
    }
    return;
  }
  /*
else begin
writeln(output,'parsedword[1]: "', parsedword[1],'"');
writeln(output,'parsedword[2]: "', parsedword[2],'"');
writeln(listing,'boop');
halt;
error(2);
end
*/

  irword(LINK);
  if (!LINK->LINK->correct)
    return;
  if ((unsigned long)LINK->LINK->word < 32 &&
      ((1L << ((long)LINK->LINK->word)) &
       ((1L << ((long)comdelila)) | (1L << ((long)homdelila)))) != 0) {
    switch (LINK->LINK->word) {

    case comdelila:
      LINK->LINK->dirwanted = dircomplement;
      break;

    case homdelila:
      LINK->LINK->dirwanted = dirhomologous;
      break;
    }
    return;
  }
  if (LINK->LINK->word != (int)piedelila &&
      LINK->LINK->word != (int)gendelila &&
      LINK->LINK->word != (int)tradelila &&
      LINK->LINK->word != (int)mardelila) {
    error(7L, LINK->LINK);
    geteoinst(LINK);
    return;
  }
  if (LINK->LINK->pass != 2)
    return;
  switch (LINK->LINK->word) {

  case mardelila:
    specified(LINK->LINK->mkspec, LINK);
    if (LINK->LINK->correct)
      LINK->LINK->dirwanted = LINK->LINK->mkoff->key.ref.refdir;
    else
      error(202L, LINK->LINK);
    break;

  case tradelila:
    specified(LINK->LINK->tkspec, LINK);
    if (LINK->LINK->correct)
      LINK->LINK->dirwanted = LINK->LINK->tk.ref.refdir;
    break;

  case gendelila:
    specified(LINK->LINK->gkspec, LINK);
    if (LINK->LINK->correct)
      LINK->LINK->dirwanted = LINK->LINK->gk.ref.refdir;
    break;

  case piedelila:
    specified(LINK->LINK->pkspec, LINK);
    if (LINK->LINK->correct)
      LINK->LINK->dirwanted = LINK->LINK->pk->key.piedir;
    break;
  }
}

Local Void irwith(LINK)
struct LOC_readinstruction *LINK;
{
  /* <with> */
  /* read markers into mkon */
  /* check that:
        1) each marker refers to the currently specified piece (warning)
        2) each marker is within the piece (warning message)
        3) there are no overlapping markers since one can not make
           them recombine (fatal error message)
        then string those markers that do not violate 1 and 2 into mkon
        in the order of the piece.
        the with instruction may not need parenthesis, see the section
        on numbering default.
        see also respecification for use of parenthesis */
  /*
writeln(output,'IN irwith');
*/

  /* 2000 Oct 18: Set withused on during the first pass so that if there are
     statements without a 'with', they will trigger stepping the piece forward
     even if they are before the withs that come later in the inst.
     This keeps the marks properly aligned with the sequences.
     (Prior to this date the test was "(not withused) and (pass = 2)".) */
  if (!withused) {
    if (*marksdelila.name != '\0') {
      if (marksdelila.f != NULL)
	marksdelila.f = freopen(marksdelila.name, "w", marksdelila.f);
      else
	marksdelila.f = fopen(marksdelila.name, "w");
    } else {
      if (marksdelila.f != NULL)
	rewind(marksdelila.f);
      else
	marksdelila.f = tmpfile();
    }
    if (marksdelila.f == NULL)
      _EscIO2(FileNotFound, marksdelila.name);
    SETUPBUF(marksdelila.f, Char);
    marksautomate(&marksdelila);
    withused = true;
  }

  readchangeset(&mutations, LINK);
  /*
writechangeset(output, mutations);
writeln(output,'after writechangeset');
*/
  LINK->LINK->numofchanges = mutations.number;
}

Local Void irdirwit(LINK)
struct LOC_readinstruction *LINK;
{
  /* <direction><with> */
  /* sets directionwanted and mkon */
  if (LINK->LINK->word != (int)witdelila && LINK->LINK->word != (int)dirdelila)
    return;
  if (LINK->LINK->word == witdelila) {
    irwith(LINK);
    return;
  }
  if (LINK->LINK->word != dirdelila) {
    error(7L, LINK->LINK);
    return;
  }
  irdirection(LINK);
  if (!LINK->LINK->correct)
    return;
  if (!LINK->LINK->eoinst)
    findword(LINK);
  if (LINK->LINK->eoinst)
    return;
  if (LINK->LINK->word != witdelila)
    irword(LINK);
  if (!LINK->LINK->correct)
    return;
  if (LINK->LINK->word == witdelila)
    irwith(LINK);
  else
    error(7L, LINK->LINK);
}

/* higher level procedures ************************************************/

Local Void outofrange(pie, p, LINK)
piece *pie;
long *p;
struct LOC_readinstruction *LINK;
{
  /* p is out of range of the piece pie */
  piekey *WITH;

  WITH = &pie->key;
  switch (def.defout) {

  case rreduce:  /* force it into the piece */
    error(208L, LINK->LINK);
    reduceposition(pie, p);
    ivalueposition(*p, LINK->LINK);
    /* If the position is the same as before ... */
    if (*p == LINK->LINK->previousfromposition) {
      /* if this is the second reduce for the instruction */
      if (LINK->LINK->reduced) {
	/* this is a reduction from one side and is
	   likely be a mistake */
	error(210L, LINK->LINK);
      } else
	LINK->LINK->reduced = true;
    }
    LINK->LINK->correct = true;
    break;

  case rcontinue:  /* ignore it with a warning */
    error(209L, LINK->LINK);
    LINK->LINK->correct = false;   /* skip rest of statement */
    geteoinst(LINK);
    break;

  case rhalt:  /* die horribly */
    error(203L, LINK->LINK);
    LINK->LINK->correct = false;   /* skip rest of statement */
    geteoinst(LINK);
    break;
  }
}

Local Void known(theposition, LINK)
long *theposition;
struct LOC_readinstruction *LINK;
{
  /* is the position known?
     the convention is that a reference outside
     the coordinate system is unknown */
  if (!between(libpie->key.coobeg, *theposition, libpie->key.cooend)) {
    error(206L, LINK->LINK);
    outofrange(libpie, theposition, LINK);
  }
}

Local Void okposition(p, LINK)
long *p;
struct LOC_readinstruction *LINK;
{
  /* is the position ok? (within the range of the piece).
2007 Dec 06: if not within AND circular piece always reduce */
  if (within(libpie, *p))
    return;
  if (libpie->key.piecon == circular)   /* new as of 2007 Dec 06 */
    reduceposition(libpie, p);
  /*qqq*/
  else
    outofrange(libpie, p, LINK);
}

/* Local variables for posit: */
struct LOC_posit {
  struct LOC_readinstruction *LINK;
  long *theposition;
} ;

Local Void relative(LINK)
struct LOC_posit *LINK;
{
  /* read a <relative> number */
  findword(LINK->LINK);
  if (!(LINK->LINK->LINK->correct &&
	(LINK->LINK->LINK->chr == '-' || LINK->LINK->LINK->chr == '+')))
    return;
  zerobase = *LINK->theposition;   /* pick up the default coordinate base */
  /*writeln(output,'proc.relative: zerobase = ',zerobase:1);*/
  irnumber(LINK->LINK);
  *LINK->theposition += LINK->LINK->LINK->inumber;
  if (LINK->LINK->LINK->correct)
    ivalueposition(*LINK->theposition, LINK->LINK->LINK);
}

Local Void limitref(ref, LINK)
reference ref;
struct LOC_posit *LINK;
{
  /* handle <limit>s of references */
  if (LINK->LINK->LINK->pass == 2) {
    if (strncmp(ref.pienam.letters, libpie->key.hea.keynam.letters,
		sizeof(alpha)))
      error(205L, LINK->LINK->LINK);
  }
  if (!LINK->LINK->LINK->correct)
    return;
  irword(LINK->LINK);
  if (!LINK->LINK->LINK->correct)
    return;
  if ((unsigned long)LINK->LINK->LINK->word >= 32 ||
      ((1L << ((long)LINK->LINK->LINK->word)) &
       ((1L << ((long)begdelila)) | (1L << ((long)enddelila)))) == 0) {
    error(7L, LINK->LINK->LINK);
    return;
  }
  if (LINK->LINK->LINK->pass != 2)
    return;
  switch (LINK->LINK->LINK->word) {

  case begdelila:
    *LINK->theposition = ref.refbeg;
    break;

  case enddelila:
    *LINK->theposition = ref.refend;
    break;
  }
  known(LINK->theposition, LINK->LINK);
}

Local Void limitmkoff(mkoff, LINK)
marker *mkoff;
struct LOC_posit *LINK;
{
  /* get limits for marker */
  if (numbered_(LINK->LINK->LINK->mkspec, LINK->LINK))
    ivaluenumber((long)LINK->LINK->LINK->mkspec, LINK->LINK->LINK);
  limitref(mkoff->key.ref, LINK);
}

Local Void limittk(tk, LINK)
trakey tk;
struct LOC_posit *LINK;
{
  /* get limits for transcript */
  if (numbered_(LINK->LINK->LINK->tkspec, LINK->LINK))
    ivaluenumber((long)LINK->LINK->LINK->tkspec, LINK->LINK->LINK);
  limitref(tk.ref, LINK);
}

Local Void limitgk(gk, LINK)
genkey gk;
struct LOC_posit *LINK;
{
  /* get limits for gene */
  if (numbered_(LINK->LINK->LINK->gkspec, LINK->LINK))
    ivaluenumber((long)LINK->LINK->LINK->gkspec, LINK->LINK->LINK);
  limitref(gk.ref, LINK);
}

Local Void limitpk(pk, LINK)
piece *pk;
struct LOC_posit *LINK;
{
  /* get limits for piece */
  piekey *WITH;

  ivaluenumber((long)LINK->LINK->LINK->pkspec, LINK->LINK->LINK);
  irword(LINK->LINK);
  if (!LINK->LINK->LINK->correct)
    return;
  if ((unsigned long)LINK->LINK->LINK->word >= 32 ||
      ((1L << ((long)LINK->LINK->LINK->word)) &
       ((1L << ((long)begdelila)) | (1L << ((long)enddelila)))) == 0) {
    error(7L, LINK->LINK->LINK);
    return;
  }
  if (LINK->LINK->LINK->pass != 2)
    return;
  WITH = &pk->key;
  switch (LINK->LINK->LINK->word) {

  case begdelila:
    *LINK->theposition = WITH->piebeg;
    break;

  case enddelila:
    *LINK->theposition = WITH->pieend;
    break;
  }
}

Local Void limitco(pk, LINK)
piece *pk;
struct LOC_posit *LINK;
{
  /* get limits for coordinate system */
  piekey *WITH;

  ivaluenumber((long)LINK->LINK->LINK->pkspec, LINK->LINK->LINK);
  irword(LINK->LINK);
  if (!LINK->LINK->LINK->correct)
    return;
  if ((unsigned long)LINK->LINK->LINK->word >= 32 ||
      ((1L << ((long)LINK->LINK->LINK->word)) &
       ((1L << ((long)begdelila)) | (1L << ((long)enddelila)))) == 0) {
    error(7L, LINK->LINK->LINK);
    return;
  }
  if (LINK->LINK->LINK->pass != 2)
    return;
  WITH = &pk->key;
  switch (LINK->LINK->LINK->word) {

  case begdelila:
    *LINK->theposition = WITH->coobeg;
    break;

  case enddelila:
    *LINK->theposition = WITH->cooend;
    break;
  }
}

Local Void posit(theposition_, LINK)
long *theposition_;
struct LOC_readinstruction *LINK;
{  /* <position> */
  /* read a <position> */
  /* not implemented
var
        (* variables for <respecification> *)
        remkoff: markerptr;
        retk: trakey;
        regk: genkey;
  */
  struct LOC_posit V;

  V.LINK = LINK;
  V.theposition = theposition_;
  findword(LINK);
  if (P_inset(LINK->LINK->chr, LINK->LINK->numbers) ||
      LINK->LINK->chr == '-' || LINK->LINK->chr == '+')
  {  /* <number> */
    irnumber(LINK);   /* does the ivalueposition */
    if (LINK->LINK->correct) {
      *V.theposition = LINK->LINK->inumber;
      LINK->LINK->previousfromposition = *V.theposition;
      relative(&V);
    }
  }

  else if (LINK->LINK->chr == 's') {  /* should be a 'same' */
    irword(LINK);
    if (LINK->LINK->correct) {
      if (LINK->LINK->word == samdelila) {
	if (LINK->LINK->sameusageisvalid) {
	  *V.theposition = LINK->LINK->previousfromposition;
	  relative(&V);
	} else {
	  error(18L, LINK->LINK);
	  geteoinst(LINK);
	}
      }
    }
  }


  else {
    if (LINK->LINK->parentheses == 1) {  /* <respecification> */
      irword(LINK);

      /* not implemented
                  if correct then begin
                     if word in [mardelila,tradelila,gendelila] then begin
                        save:=word;
                        irkeyname;
                        if correct then begin
                           case save of
                              mardelila: begin
                                 remkoff := nil;
                                 getmarker(remkoff);
                                 startheader(remkoff^.key.hea);
                                 with remkoff^.key do begin
                                    phenotype := nil;
                                    next := nil
                                 end;
                                 if pass=2 then lrmarker(keyname,remkoff)
                                           else itemfound:=true;
                                 if itemfound then limitref(remkoff^.key.ref)
                                              else error(201);
                                 clearheader(remkoff^.key.hea);
                                 clearmarker(remkoff)
                              end;
                              tradelila: begin
                                 startheader(retk.hea);
                                 if pass=2 then lrtrakey(keyname,retk)
                                           else itemfound:=true;
                                 if itemfound then limitref(retk.ref)
                                              else error(201);
                                 clearheader(retk.hea)
                              end;
                              gendelila: begin
                                 startheader(regk.hea);
                                 if pass=2 then lrgenkey(keyname,regk)
                                           else itemfound:=true;
                                 if itemfound then limitref(regk.ref)
                                              else error(201);
                                 clearheader(regk.hea)
                              end
                           end

                        end
                     end
                     else error(7)
                  end;
      */

      if (LINK->LINK->correct) {
	ivalueposition(*V.theposition, LINK->LINK);
	    /* finish the last value */
	relative(&V);
      }
    } else {
      irword(LINK);
      if (LINK->LINK->correct) {
	if (LINK->LINK->word == (int)coodelila ||
	    LINK->LINK->word == (int)piedelila ||
	    LINK->LINK->word == (int)gendelila ||
	    LINK->LINK->word == (int)tradelila ||
	    LINK->LINK->word == (int)mardelila) {
	  switch (LINK->LINK->word) {

	  /* <substurcture> */
	  case mardelila:
	    if (LINK->LINK->pass == 2)
	      specified(LINK->LINK->mkspec, LINK);
	    else
	      LINK->LINK->correct = true;
	    if (LINK->LINK->correct)
	      limitmkoff(LINK->LINK->mkoff, &V);
	    else
	      error(202L, LINK->LINK);
	    break;

	  case tradelila:
	    if (LINK->LINK->pass == 2)
	      specified(LINK->LINK->tkspec, LINK);
	    else
	      LINK->LINK->correct = true;
	    if (LINK->LINK->correct)
	      limittk(LINK->LINK->tk, &V);
	    else
	      error(202L, LINK->LINK);
	    break;

	  case gendelila:
	    if (LINK->LINK->pass == 2)
	      specified(LINK->LINK->gkspec, LINK);
	    else
	      LINK->LINK->correct = true;
	    if (LINK->LINK->correct)
	      limitgk(LINK->LINK->gk, &V);
	    else
	      error(202L, LINK->LINK);
	    break;

	  case piedelila:
	    if (LINK->LINK->pass == 2)
	      specified(LINK->LINK->pkspec, LINK);
	    else
	      LINK->LINK->correct = true;
	    if (LINK->LINK->correct)
	      limitpk(LINK->LINK->pk, &V);
	    else
	      error(202L, LINK->LINK);
	    break;

	  /* coordinates */
	  case coodelila:
	    if (LINK->LINK->pass == 2)
	      specified(LINK->LINK->pkspec, LINK);
	    else
	      LINK->LINK->correct = true;
	    if (LINK->LINK->correct)
	      limitco(LINK->LINK->pk, &V);
	    else
	      error(202L, LINK->LINK);
	    break;
	  }
	} else
	  error(7L, LINK->LINK);
      }
      if (LINK->LINK->correct) {
	ivalueposition(*V.theposition, LINK->LINK);
	    /* finish the last value */
	relative(&V);
	/* <substructure> or coordinate */
      }
    }
  }
  /* <key position> */
  if (LINK->LINK->pass == 2 && LINK->LINK->correct)
    okposition(V.theposition, LINK);

}

Local Void posits(LINK)
struct LOC_readinstruction *LINK;
{
  /* read in the <positions> from, to.
     the frodelila has already been read */
  if (debugging)
    fprintf(debug.f, "positions-in\n");
  LINK->LINK->previousfromposition = 0;
  LINK->LINK->sameusageisvalid = false;
  posit(&LINK->LINK->fromposition, LINK);
  if (LINK->LINK->correct) {
    irword(LINK);
    LINK->LINK->sameusageisvalid = true;
    if (LINK->LINK->correct) {
      if (LINK->LINK->word == todelila)
	posit(&LINK->LINK->toposition, LINK);
      else
	error(7L, LINK->LINK);
    }
  }
  if (debugging)
    fprintf(debug.f, "positions-out%5ld%5ld\n",
	    LINK->LINK->fromposition, LINK->LINK->toposition);
}

Local Void absdirection(wanted, reference_, LINK)
direction *wanted, *reference_;
struct LOC_readinstruction *LINK;
{
  /* calculate the absolute direction wanted (plus or minus) relative to a
     reference direction */
  switch (*wanted) {

  case plus:
    /* blank case */
    break;

  case minus:
    /* blank case */
    break;

  case dircomplement:
    switch (*reference_) {

    case plus:
      *wanted = minus;
      break;

    case minus:
      *wanted = plus;
      break;
    }
    break;

  case dirhomologous:
    *wanted = *reference_;
    break;
  }
}

Local Void allref(ref, LINK)
reference ref;
struct LOC_readinstruction *LINK;
{
  /* does the all from a reference */
  /* decide absolute direction */
  absdirection(&LINK->LINK->dirwanted, &ref.refdir, LINK);

  /* now decide which base is first */
  if (LINK->LINK->dirwanted == ref.refdir) {
    LINK->LINK->fromposition = ref.refbeg;
    LINK->LINK->toposition = ref.refend;
  } else {
    LINK->LINK->fromposition = ref.refend;
    LINK->LINK->toposition = ref.refbeg;
  }

  ivalueposition(LINK->LINK->fromposition, LINK->LINK);
  known(&LINK->LINK->fromposition, LINK);
  if (!LINK->LINK->correct)
    return;
  ivalueposition(LINK->LINK->toposition, LINK->LINK);
  known(&LINK->LINK->toposition, LINK);
  if (LINK->LINK->correct) {
    /* there are no circular refered objects */
    LINK->LINK->pk->key.piecon = linear;
    dopiece(LINK);
  }
}

Local Void ircondition(LINK)
struct LOC_readinstruction *LINK;
{
  /* read the condition of an if statement,
     return the value in the variable choice
     thedelila = then (true) should be done
     elsdelila = else (false) should be done
  */
  /* dummy */
}

Local Void numberstructure(LINK)
struct LOC_readinstruction *LINK;
{
  /* allow the structure indicated by word to be numbered
     see the section on numbering default */
  numberedstructure indnum;   /* an index for def.num.str */

  if (P_inset(LINK->LINK->word, LINK->LINK->structure)) {
    switch (LINK->LINK->word) {

    case orgdelila:
      def.num.str[(long)orgnum] = on;
      break;

    case chrdelila:
      def.num.str[(long)chrnum] = on;
      break;

    case mardelila:
      def.num.str[(long)marnum] = on;
      break;

    case tradelila:
      def.num.str[(long)tranum] = on;
      break;

    case gendelila:
      def.num.str[(long)gennum] = on;
      break;

    case piedelila:
      def.num.str[(long)pienum] = on;
      break;

    case recdelila:
      def.num.str[(long)recnum] = on;
      break;

    case enzdelila:
      def.num.str[(long)enznum] = on;
      break;
    }
    return;
  }
  if (LINK->LINK->word == alldelila) {   /* turn all on */
    for (indnum = orgnum;
	 (long)indnum <= (long)enznum;
	 indnum = (numberedstructure)((long)indnum + 1))
      def.num.str[(long)indnum] = on;
  } else {
    error(7L, LINK->LINK);
    geteoinst(LINK);
  }
}

/**************************************************************************/
Local Void readinstruction(LINK)
struct LOC_librarian *LINK;
{  /* begin of readinstruction */
  /* read and process one instruction up to the next ';' */
  /**************************************************************************/
  /* specification procedures ***********************************************/

  /* low level routines *****************************************************/
  struct LOC_readinstruction V;
  numberedstructure indnum;   /* an index for def.num.str */
  piekey *WITH;

  /* the core of delila follows */
  /**************************************************************************/
  /**************************************************************************/
  /**************************************************************************/
  V.LINK = LINK;
  /* read an instruction from the <delila instruction set> */
  /* the conception of this part of the code is due to paul morrissett */
  LINK->eoinst = true;   /* still at end of last instruction */
  LINK->reduced = false;   /* piece ends have not been reduced yet */
  /*zzzppp*/
  mutations.number = 0;   /* force it to be clear of mutations */
  findword(&V);   /* move to first word */
  if (!BUFEOF(inst.f)) {
    LINK->eoinst = false;
	/* now we are not at the end of an instruction.... */
    irword(&V);
    if (LINK->correct) {
      if (LINK->word == titdelila) {  /* a <title> */
	if (LINK->instructioncount == 1) {
	  irtitle(&V);
	  LINK->titleexists = true;
	  if (LINK->pass == 2)   /* save space */
	    clearline(&LINK->title);
	} else {
	  if (LINK->pass == 1)
	    error(3L, LINK);
	  geteoinst(&V);
	}
      } else if (P_inset(LINK->word, LINK->structure))
      {  /* a <specification> */
	if (tvrschecks(noder(&LINK->word, &V))) {
	  irkeyname(&V);
	  if (LINK->correct) {
	    if (LINK->word == (int)enzdelila ||
		LINK->word == (int)recdelila || LINK->word == (int)mardelila)
		  /* not implemented */
		    error(0L, LINK);
	    if (LINK->pass == 2) {
	      switch (LINK->word) {

	      case orgdelila:
		lrorgkey(LINK->keyname, &LINK->ok);
		if (itemfound) {
		  spec(&LINK->ok.hea, def.num.str[(long)orgnum],
		       &LINK->okspec, &V);
		  tvrsbook(orgnode);
		  bworgkey(&book, LINK->ok);
		  /* make lower nodes unspecified */
		  unspec(&LINK->ckspec, &V);
		  unspecbelowck(&V);
		} else
		  error(201L, LINK);
		break;

	      case chrdelila:
		lrchrkey(LINK->keyname, &LINK->ck);
		if (itemfound) {
		  spec(&LINK->ck.hea, def.num.str[(long)chrnum],
		       &LINK->ckspec, &V);
		  tvrsbook(chrnode);
		  bwchrkey(&book, LINK->ck);
		  unspecbelowck(&V);
		} else
		  error(201L, LINK);
		break;

	      /* not implemented
	                          mardelila: begin
	                            lrmarker(keyname,mkoff);
	                            if itemfound then begin
	                              spec(mkoff^.key.hea,def.num.str[marnum],mkspec);
	                              if def.key.mar=on
	                                 then bwmarkers(mkoff)
	                                 else clearmarker(mkoff);
	                              specpiece(mkoff^.key.ref)
	                            end
	                            else error(201)
	                          end;

	                          tradelila: begin
	                            lrtrakey(keyname,tk);
	                            if itemfound then begin
	                              spec(tk.hea,def.num.str[tranum],tkspec);
	                              if def.key.tra = on then bwtrakey(tk);
	                              specpiece(tk.ref)
	                            end
	                            else error(201)
	                          end;
	      */
	      case gendelila:
		lrgenkey(LINK->keyname, &LINK->gk);
		if (itemfound) {
		  spec(&LINK->gk.hea, def.num.str[(long)gennum],
		       &LINK->gkspec, &V);
		  if (def.key.gen == on)
		    bwgen(&book, LINK->gk);
		  specpiece(LINK->gk.ref, &V);
		} else
		  error(201L, LINK);
		break;

	      case piedelila:
		lrpiece(LINK->keyname, &libpie);
		if (itemfound)
		  LINK->pkspec = -0.5;
		else {
		  /* do not write piece here,
		     but rather, at the request */
		  error(201L, LINK);
		}
		break;
		/* not implemented
		                    recdelila: begin
		                      lrreckey(keyname,rk);
		                      if itemfound then begin
		                        spec(rk.hea,def.num.str[recnum],rkspec);
		                        bwreckey(rk);
		                        unspec(ekspec)
		                      end
		                      else error(201)
		                    end;
		                    enzdelila: begin
		                      lrenzyme(keyname,ek);
		                      if itemfound then begin
		                        spec(ek^.key.hea,def.num.str[enznum],ekspec);
		                        bwenzyme(ek)
		                      end
		                      else error(201)
		                    end;
		*/
	      }
	    }  /* pass */
	  }  /* correct keyname */

	}  /* traverse check */
	else {
	  error(6L, LINK);
	  geteoinst(&V);
	}
      }
      /*zzzwww*/
      else if (LINK->word == getdelila) {  /* a <request> */
	/* give the piece a number */
	if (LINK->pass == 2) {
	  specified(LINK->pkspec, &V);   /* was the piece (fake) specified? */
	  if (LINK->correct) {
	    /*
writeln(output,'spec(pk^.key.hea,def.num.str[pienum],pkspec) ****');
writeln(output,'def.num.str[pienum] = ',def.num.str[pienum]:1);
writeln(output,'pkspec = ',pkspec:1);
*/
	    /* put the number into the pk now so that
	       it gets listed properly on the listing */
	    copyline(libpie->key.hea.note, &LINK->pk->key.hea.note);
	    spec(&LINK->pk->key.hea, def.num.str[(long)pienum], &LINK->pkspec,
		 &V);

	    /*libpkset*/
	    /*
writeln(output,'getdelila @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@');
write(output,'libpie^.key.hea.keynam: "');
writename(output,libpie^.key.hea.keynam);
writeln(output,'"');
write(output,'pk^.key.hea.keynam:     "');
writename(output,pk^.key.hea.keynam);
writeln(output,'"');
*/

	    /* we better remove any previous pieces or we will run out
	       of memory pretty darn quick!! */
	    clearpiece(&LINK->pk);

	    /* since we are starting to get the piece, fill it out as
	       much as we can */
	    copyname(libpie->key.hea.keynam, &LINK->pk->key.hea.keynam);
	    /*zzzDDD*/
	    /* make sure the number is in the piece: */
	    addnumber(&LINK->pk->key.hea, def.num.item, &V);
	    LINK->pk->key.mapbeg = libpie->key.mapbeg;
	    LINK->pk->key.coocon = libpie->key.coocon;
	    LINK->pk->key.coodir = libpie->key.coodir;
	    LINK->pk->key.coobeg = libpie->key.coobeg;
	    LINK->pk->key.cooend = libpie->key.cooend;
	    LINK->pk->key.piecon = libpie->key.piecon;
	    LINK->pk->key.piedir = libpie->key.piedir;
	    LINK->pk->key.piebeg = libpie->key.piebeg;
	    LINK->pk->key.pieend = libpie->key.pieend;

	    /*
writeln(output,'getdelila: pk^.key.coocon ', pk^.key.coocon);
writeln(output,'getdelila: libpie^.key.coocon ', libpie^.key.coocon);
writeln(output,'getdelila: pk^.key.piecon is ', pk^.key.piecon);
writeln(output,'getdelila: libpie^.key.piecon is ', libpie^.key.piecon);
*/
	    /*zzzsss*/
	  } else {
	    error(202L, LINK);
	    geteoinst(&V);
	  }
	}
	if (LINK->correct)   /* <range> */
	  irword(&V);
	if (LINK->correct) {
	  /* set up defaults */
	  LINK->dirwanted = dirhomologous;
	  LINK->cutposition = LINK->pk->key.coobeg;
	      /* default cut position */
	  while (LINK->mkon != NULL)
	    clearmarker(&LINK->mkon);
	  /* figure out the kind of range */
	  if (LINK->word == frodelila) {
	    posits(&V);
	    if (LINK->correct) {
	      if (!LINK->eoinst) {
		irword(&V);
		if (LINK->correct)
		  irdirwit(&V);
	      }
	      if (LINK->correct && LINK->pass == 2) {
		LINK->pk->key.piecon = linear;
		    /* positions forces linearity */
		dopiece(&V);
		geteoinst(&V);
	      }
	    } else
	      geteoinst(&V);
	  } else if (LINK->word == alldelila) {  /* get <all> */
	    irword(&V);
	    if (LINK->correct) {  /* do cut, direction and with */
	      if (P_inset(LINK->word, LINK->structure)) {
		LINK->save = LINK->word;
		if (!LINK->eoinst)
		  findword(&V);
		if (!LINK->eoinst) {  /* parse: cut, direction, with */
		  irword(&V);
		  if (LINK->correct) {
		    if (LINK->word == (int)witdelila ||
			LINK->word == (int)dirdelila ||
			LINK->word == (int)cutdelila) {
		      if (LINK->word == cutdelila) {
			if (LINK->save == piedelila) {
			  if (LINK->pass == 2) {
			    if (libpie->key.piecon != circular)
			      error(207L, LINK);
			  }
			  if (LINK->correct) {
			    posit(&LINK->cutposition, &V);   /* <cut> */
			    if (LINK->correct && !LINK->eoinst) {
			      irword(&V);
			      if (LINK->correct)
				irdirwit(&V);
			    }
			  }
			} else {
			  error(8L, LINK);
			  geteoinst(&V);
			}
		      } else
			irdirwit(&V);
		    } else
		      error(7L, LINK);
		  }
		}
		/* now do the all */
		if (LINK->correct) {
		  if (LINK->save == (int)enzdelila ||
		      LINK->save == (int)recdelila ||
		      LINK->save == (int)mardelila ||
		      LINK->save == (int)chrdelila ||
		      LINK->save == (int)orgdelila)
		    error(0L, LINK);
		}
		if (LINK->correct && LINK->pass == 2) {
		  switch (LINK->save) {

		  case orgdelila:
		    /* blank case */
		    break;

		  case chrdelila:
		    /* blank case */
		    break;

		  case mardelila:
		    specified(LINK->mkspec, &V);
		    if (LINK->correct)
		      allref(LINK->mkoff->key.ref, &V);
		    else
		      error(202L, LINK);
		    break;

		  case tradelila:
		    specified(LINK->tkspec, &V);
		    if (LINK->correct)
		      allref(LINK->tk.ref, &V);
		    else
		      error(202L, LINK);
		    break;

		  case gendelila:
		    specified(LINK->gkspec, &V);
		    if (LINK->correct)
		      allref(LINK->gk.ref, &V);
		    else
		      error(202L, LINK);
		    break;

		  case piedelila:
		    /* we checked the specification
		       after the get */
		    WITH = &LINK->pk->key;
		    absdirection(&LINK->dirwanted, &libpie->key.piedir, &V);
		    if (WITH->piecon == linear) {
		      if (LINK->dirwanted == libpie->key.piedir) {
			LINK->fromposition = libpie->key.piebeg;
			LINK->toposition = libpie->key.pieend;
		      } else {
			LINK->fromposition = libpie->key.pieend;
			LINK->toposition = libpie->key.piebeg;
		      }
		    } else {
		      LINK->fromposition = LINK->cutposition;
		      /* figure out toposition.  there are 6 cases
		         to consider for this base:
		       reversing  cut at (coordinate position):
		                  begin      end        other
		       yes        succ(cut)  begin      succ(cut)
		       no         end        pred(cut)  pred(cut)
		      */
		      /* if reversing . . . */
		      if (LINK->dirwanted != libpie->key.piedir) {
			if (LINK->cutposition == WITH->cooend)
			  LINK->toposition = WITH->coobeg;
			else
			  LINK->toposition = LINK->cutposition + 1;
		      } else if (LINK->cutposition == WITH->coobeg)
			LINK->toposition = WITH->cooend;
		      else
			LINK->toposition = LINK->cutposition - 1;
		    }
		    /* piecon = circular */
		    ivalueposition(LINK->fromposition, LINK);
		    ivalueposition(LINK->toposition, LINK);
		    /*zzzsss*/
		    /*
writeln(output,'allcall');
writeln(output,'pk^.key.piecon is ', pk^.key.piecon);
writeln(output,'libpie^.key.piecon is ', libpie^.key.piecon);
writeln(output,'PASS 2 at get from/to dopiece call <<<<<<<<<<<<<<<<<<<<<');
*/
		    dopiece(&V);
		    geteoinst(&V);
		    /*zzzthe following is probably irrelevant now and so geteoinst can be
removed.   do so when life is calm...  however, another place that
calls dopiece has geteoinst, so ????*/
		    /* Previously (prior to 1999 March 21) geteoinst
		       was done before dopiece.  But to allow the
		       changeset reading routines to violate the
		       stupid ichread mechanism, I removed the
		       geteoinst from irwith.  This allows the
		       listing to have the #s and mutations done
		       neatly. */
		    break;

		  case recdelila:
		    /* blank case */
		    break;

		  case enzdelila:
		    /* blank case */
		    break;
		  }
		}
	      }
	    }
	  } else if (LINK->word == evedelila) {  /* get <every> */
	    irword(&V);
	    if (LINK->correct) {
	      if (P_inset(LINK->word, LINK->structure)) {
		/* dummy.  for the most part this could
		   be a search for the type and then a copy
		   library to book (except gen and tra, and
		   non-printing due to def.key.xxx=off */
		error(0L, LINK);
	      } else
		error(7L, LINK);
	    }
	  } else
	    error(7L, LINK);
	}
      } else if (LINK->word == ifdelila) {  /* an <if> statement */
	/* this is a recursive call.. readinst is used. */
	ircondition(&V);
	if (LINK->correct) {
	  irword(&V);
	  if (LINK->correct) {
	    if (LINK->word == thedelila) {  /* then */
	      /* dummy */
	      error(0L, LINK);
	    } else
	      error(7L, LINK);
	  }
	}
      } else if (LINK->word == defdelila || LINK->word == setdelila)
	  /* <SET> */
	  {  /* a <default> */
	irword(&V);
	if (LINK->correct) {
	  if (LINK->word == keydelila) {  /* a <key default> */
	    irword(&V);
	    if (LINK->correct) {
	      if (LINK->word == (int)tradelila ||
		  LINK->word == (int)gendelila ||
		  LINK->word == (int)mardelila ||
		  LINK->word == (int)notdelila) {
		LINK->save = LINK->word;
		irword(&V);
		if (LINK->correct) {
		  if ((unsigned long)LINK->word < 32 &&
		      ((1L << ((long)LINK->word)) & ((1L << ((long)ondelila)) |
			 (1L << ((long)offdelila)))) != 0) {
		    if (LINK->pass == 2) {
		      switch (LINK->save) {

		      case notdelila:
			if (LINK->word == ondelila)
			  def.key.note = on;
			else
			  def.key.note = off;
			break;

		      case mardelila:
			if (LINK->word == ondelila)
			  def.key.mar = on;
			else
			  def.key.mar = off;
			break;

		      case gendelila:
			if (LINK->word == ondelila)
			  def.key.gen = on;
			else
			  def.key.gen = off;
			break;

		      case tradelila:
			if (LINK->word == ondelila)
			  def.key.tra = on;
			else
			  def.key.tra = off;
			break;
		      }
		    }
		  } else
		    error(7L, LINK);
		}
	      } else
		error(7L, LINK);
	    }
	  } else if (LINK->word == sitdelila) {
	    /* <recognition site default> */
	    irword(&V);
	    if (LINK->correct) {
	      if ((unsigned long)LINK->word < 32 &&
		  ((1L << ((long)LINK->word)) & ((1L << ((long)expdelila)) |
		     (1L << ((long)moddelila)) | (1L << ((long)cledelila)))) != 0) {
		LINK->save = LINK->word;
		irword(&V);
		if (LINK->correct) {
		  if ((unsigned long)LINK->word < 32 &&
		      ((1L << ((long)LINK->word)) & ((1L << ((long)ondelila)) |
			 (1L << ((long)offdelila)))) != 0) {
		    if (LINK->eoinst) {
		      if (LINK->pass == 2) {
			switch (LINK->save) {

			case expdelila:
			  if (LINK->word == ondelila)
			    def.sit.expand = on;
			  else
			    def.sit.expand = off;
			  break;

			case moddelila:
			  if (LINK->word == ondelila)
			    def.sit.modify = on;
			  else
			    def.sit.modify = off;
			  break;

			case cledelila:
			  if (LINK->word == ondelila)
			    def.sit.cleave = on;
			  else
			    def.sit.cleave = off;
			  break;
			}
		      }
		    }
		  } else
		    error(7L, LINK);
		}
	      } else
		error(7L, LINK);
	    }
	  }

	  else if (LINK->word == outdelila) {  /* a <range default> */
	    irword(&V);
	    if (LINK->correct) {
	      if (LINK->word == (int)haldelila ||
		  LINK->word == (int)condelila ||
		  LINK->word == (int)reddelila) {
		if (LINK->pass == 2) {
		  switch (LINK->word) {

		  case reddelila:
		    def.defout = rreduce;
		    break;

		  case condelila:
		    def.defout = rcontinue;
		    break;

		  case haldelila:
		    def.defout = rhalt;
		    break;
		  }
		}
	      } else
		error(7L, LINK);
	    }
	  }

	  /* new code 1995 January 24 */
	  else if (LINK->word == coodelila) {  /* a <coordinate default> */
	    /*writeln(output,'parsing<coordinate default>');*/
	    findword(&V);
	    if (P_inset(LINK->chr, LINK->numbers) || LINK->chr == '-' ||
		LINK->chr == '+') {
	      /*writeln(output,'parsing<coordinate default>: presume it is a number');*/
	      /* new code 1995 Nov 13 */
	      irnumber(&V);   /* does the ivalueposition, but so what? */
	      if (LINK->correct) {
		/*writeln(output,'the number read is ',inumber:1);*/
		def.coo = coorzero;
		zeroshift = LINK->inumber;
	      }
	    }
	    /*zzzlll*/
	    else {
	      irword(&V);
	      if (LINK->correct) {
		/*writeln(output,'parsing<coordinate default>: word read ok');*/
		if (LINK->word == (int)zerdelila ||
		    LINK->word == (int)nordelila) {
		  /*writeln(output,'parsing<coordinate default>: word',
		                  ' was nordelila or zerdelila');*/
		  if (LINK->pass == 2) {
		    /*writeln(output,'parsing<coordinate default>: pass=2');*/
		    switch (LINK->word) {

		    /*      coordinatetype = (coornormal,coorzero); */
		    case nordelila:
		      def.coo = coornormal;
		      break;

		    case zerdelila:
		      def.coo = coorzero;
		      break;
		    }
		  }
		}
	      }
	    }
	  }

	  /* new code 1999 March 20 */
	  else if (LINK->word == doudelila) {  /* a <doubling default> */
	    /*writeln(output,'parsing<doubling default>');*/
	    irword(&V);
	    if (LINK->correct) {
	      if ((unsigned long)LINK->word < 32 &&
		  ((1L << ((long)LINK->word)) &
		   ((1L << ((long)ondelila)) | (1L << ((long)offdelila)))) != 0) {
		if (LINK->word == ondelila)
		  def.doubling = on;
		else
		  def.doubling = off;
	      } else
		error(7L, LINK);
	    }
	  }
	  /*zzzlll*/

	  /* new code 1999 March 20 */
	  else if (LINK->word == arrdelila) {  /* a <arrow default> */
	    /*writeln(output,'parsing<arrowlength default>');*/
	    findword(&V);
	    if (P_inset(LINK->chr, LINK->numbers) || LINK->chr == '-' ||
		LINK->chr == '+') {
	      irnumber(&V);
	      if (LINK->correct) {
		/*
writeln(output,'the number read is ',rnumber:20:15);
*/
		/* force arrows to be downwards.  This also prevents a
		   postscript bomb if the arrow length were 0 (when
		   changeupperbits=changelowerbits) */
		if (LINK->rnumber < 0.1)
		  LINK->rnumber = 0.1;
		def.arrowlength = LINK->rnumber;
		changeupperbits = def.arrowlength + changelowerbits;
	      }
	    }
	  }

	  else if (LINK->word == numdelila) {  /* <numbering default> */
	    findword(&V);   /* get first character in chr */
	    if (!LINK->eoinst) {
	      if (P_inset(LINK->chr, LINK->numbers) || LINK->chr == '-' ||
		  LINK->chr == '+')
	      {  /* <signed number> */
		irnumber(&V);   /* the extra findword will not hurt */
		if (LINK->correct) {
		  if (LINK->pass == 2)
		    def.num.item = LINK->inumber - 1;
		}
	      } else {
		irword(&V);
		if (LINK->correct) {
		  if ((unsigned long)LINK->word < 32 &&
		      ((1L << ((long)LINK->word)) &
		       ((1L << ((long)ondelila)) | (1L << ((long)offdelila)))) != 0)
		  {   /* <state> */
		    switch (LINK->word) {

		    case ondelila:
		      def.num.sta = on;
		      break;

		    case offdelila:
		      def.num.sta = off;
		      break;
		    }
		  } else {
		    /* clear all numbering */
		    /*iii*/
		    for (indnum = orgnum;
			 (long)indnum <= (long)enznum;
			 indnum = (numberedstructure)((long)indnum + 1))
		      def.num.str[(long)indnum] = off;
		    numberstructure(&V);   /* the first one */
		    while (!LINK->eoinst) {  /* all the others */
		      findword(&V);
		      if (LINK->eoinst)
			break;
		      irword(&V);
		      if (LINK->correct) {
			numberstructure(&V);
			/* <structure set> */
		      }
		    }
		  }
		}
	      }
	    } else {
	      /* state or structure */
	      error(15L, LINK);
	    }
	  } else
	    error(7L, LINK);
	}
      }

      else if (LINK->word == notdelila) {  /* <note insertion> */
	irquote(&LINK->usernotes, &V);
	if (LINK->pass == 1) {   /* remove these extra notes */
	  while (LINK->usernotes != NULL)
	    clearline(&LINK->usernotes);
	}
      }

      else if (LINK->word == namdelila) {  /* <name> */
	irlongname(&V);
	if (LINK->pass == 1)   /* remove these extra notes */
	  emptyline(&longname);
      }

      else
	error(7L, LINK);
    } else
      geteoinst(&V);
  }
  /* first instruction word not correct */
  LINK->instructioncount++;
  if (!LINK->eoinst) {   /* catch all cases of extra stuff */
    findword(&V);   /* give um one chance */
    if (!LINK->eoinst) {
      error(1L, LINK);
      geteoinst(&V);
    }
  }
  if (LINK->parentheses != 0) {
    error(11L, LINK);
    LINK->parentheses = 0;   /* prevents snowballing */
  }
  if (LINK->chr == ';')   /* get past the ; */
    ichread(&V);

}  /* end of readinstruction */


/**************************************************************************/
/**************************************************************************/
Static Void librarian()
{
  /* by paul morrissett
     readinstruction modified, and supporting routines written
     by tom schnieder */
  /* there are two passes made through the delila instructions.

        pass 1 reads the code using ir routines (which all rely on
procedure ichread to read the instructions).
nothing happens when delila gets to a 'peak' in the code (after
passing all the if statements), since this represents a syntactically
correct instruction.  (in other words, the fact that one got to a
certain spot in the code means that so far the instruction is correct.)
ichread is responsible for writing the lines into the listing during this
pass.  instructions are written as they are scanned.  all writes are
done inside the read procedures.  syntax errors are pointed to.
the title is read, if it is in the instructions.

        pass 2 runs only if pass 1 had no errors.
the instructions are reread, and variables are collected.
calls to the library read, and the book write routines are then made.
numerical values and numbers of items are pointed to.

        note on irs and the parser:
these routines assume that the previous actions left the inst
file in good order.  this means that they have read past all they
needed, and they have read their parse stop symbol.  they need not
have done a findword however, so this is often required as the
first action of an ir.  (extra findword calls will not hurt.)
  */
  struct LOC_librarian V;
  _TEXT TEMP;


  initializedelila(&V);

  /* pass 1: check syntax and grammer */
  V.pass = 1;
  printf("Pass 1\n");

  initreadinst(&V);
  while (!BUFEOF(inst.f))
    readinstruction(&V);
  if (!V.titleexists)
    error(17L, &V);

  if (!tvrschecks(libnode)) {
    error(6L, &V);
    writeerrors(&V);
  }
  putc('\n', listing.f);
  writepasserrors(&listing, (long)V.pass, &V);
  TEMP.f = stdout;
  *TEMP.name = '\0';
  writepasserrors(&TEMP, (long)V.pass, &V);

  /* if there were no errors in the first pass, then do pass 2 */
  if (!V.pass1errors) {
    printf("Pass 2\n");
    /* pass 2: read library, create book */
    V.pass = 2;
    if (*inst.name != '\0') {
      if (inst.f != NULL)
	inst.f = freopen(inst.name, "r", inst.f);
      else
	inst.f = fopen(inst.name, "r");
    } else
      rewind(inst.f);
    if (inst.f == NULL)
      _EscIO2(FileNotFound, inst.name);
    RESETBUF(inst.f, Char);   /* go back to start of instruction file */

    bwbookheader(&V.title);   /* the first pass picked up the title */
    fprintf(listing.f, "\f");
    initreadinst(&V);
    while (!BUFEOF(inst.f) && !V.pass2errors)
      readinstruction(&V);
    putc('\n', listing.f);   /* finish last line */
    writelineinformation(&V);
    if (V.pass2errors) {
      writeerrors(&V);   /* for that line */
      bookhalt(&V);
    } else {
      tvrslibrary(libnode);
      tvrsbook(libnode);
    }
    /* close up shop */
    putc('\n', listing.f);
    writepasserrors(&listing, (long)V.pass, &V);
	/* picks up warnings also */
    TEMP.f = stdout;
    *TEMP.name = '\0';
    writepasserrors(&TEMP, (long)V.pass, &V);   /* picks up warnings also */
  } else
    bookhalt(&V);

  if (V.pass2errors || V.pass1errors)
    printf("Error(s) in pass %d: see the listing file for details\n", V.pass);
  if (V.warnings)
    printf("There are warnings: see the listing\n");

  printf("%ld piece", V.getcount);
  if (V.getcount != 1)
    putchar('s');
  printf(" extracted\n");

  printf("%ld base", booksize);   /* compared to maxbook */
  if (booksize != 1)
    putchar('s');
  printf(" extracted\n");
}  /* librarian */

#undef pagelength
#undef widinst
#undef minword
#undef max1errors
#undef max2errors
#undef maxerrors
#undef maxpositions
#undef maxnumbers
#undef numberlength


/* main library calls *****************************************************/

main(argc, argv)
int argc;
Char *argv[];
{
  PASCAL_MAIN(argc, argv);
  if (setjmp(_JL1))
    goto _L1;
  debug.f = NULL;
  strcpy(debug.name, "debug");
  marksdelila.f = NULL;
  strcpy(marksdelila.name, "marksdelila");
  book.f = NULL;
  strcpy(book.name, "book");
  listing.f = NULL;
  strcpy(listing.name, "listing");
  inst.f = NULL;
  strcpy(inst.name, "inst");
  cat3.f = NULL;
  strcpy(cat3.name, "cat3");
  cat2.f = NULL;
  strcpy(cat2.name, "cat2");
  cat1.f = NULL;
  strcpy(cat1.name, "cat1");
  lib3.f = NULL;
  strcpy(lib3.name, "lib3");
  lib2.f = NULL;
  strcpy(lib2.name, "lib2");
  lib1.f = NULL;
  strcpy(lib1.name, "lib1");
  debugging = false;   /* for debugging purposes */
  initlibrarian();
  librarian();
_L1:
  if (lib1.f != NULL)
    fclose(lib1.f);
  if (lib2.f != NULL)
    fclose(lib2.f);
  if (lib3.f != NULL)
    fclose(lib3.f);
  if (cat1.f != NULL)
    fclose(cat1.f);
  if (cat2.f != NULL)
    fclose(cat2.f);
  if (cat3.f != NULL)
    fclose(cat3.f);
  if (inst.f != NULL)
    fclose(inst.f);
  if (listing.f != NULL)
    fclose(listing.f);
  if (book.f != NULL)
    fclose(book.f);
  if (marksdelila.f != NULL)
    fclose(marksdelila.f);
  if (debug.f != NULL)
    fclose(debug.f);
  exit(EXIT_SUCCESS);
}  /* delila */



/* End. */