program catal(catalp,
              l1, cat1, lib1,
              l2, cat2, lib2,
              l3, cat3, lib3,
              humcat, catin,
              output); (* lll ccc *)

(* catal: the catalog program

      by Michael Aden and Thomas Schneider
      module libraries needed: delman, delmods.

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

*)

(* *********************************************************************)
label 1;  (* label used for the end of the program *)

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

const
(* begin module version *)
   version = 9.64; (* of catal.p 2020 Feb 20
2020 Feb 20, 9.64: add dbbk to list of See Also
2018 Sep 17, 9.63: switch to timegpc.p modules
2017 Oct 02, 9.62: ecoli fails: 'catin: Pascal system error 0'
                   This was files not permitted to be writable
2017 Jul 14, 9.61: duplicate piece name problem
                   -
                   In version 9.41 of catal originally linelength was
                   80 characters and namelength was 50 characters. 
                   Procedure changename assumes that linelength is at
                   least 2 characters longer than namelength, probably
                   because in Delila books the lines begin with '* '. 
                   So linelength should be at least 2 characters
                   longer than namelength.  I'll use 210 for safety.
                   -
2017 Jul 11, 9.60: namelength/linelength set to 300 to allow even longer names
2017 Jul 10, 9.59: namelength set to 200 to allow even longer names
2016 Jan 25, 9.58: backup
2011 Nov 03, 9.56: new parameters: no comments and get from to format
2011 Jan 19, 9.55: writepieceinfo not squish coordinates together
2004 Jul  8, 9.54: tidy up
2004 Jul  8, 9.53: fix invalid operands to binary, introduce equalname
2004 Jul  8, 9.52: attack gpc compiler errors, upgrademodule catal.p gpctime.p
2001 Mar 16, 9.51: length of date in cat file corrected
2000 Sep 25, 9.50: duplicate titles removed
1999 Mar 31, 9.49: previous change not noted
1999 Mar 18, 9.46: names only written to their length
prior version: 1998 January 27 *)
(* end module version *)

(* begin module describe.catal *)
(*
name
      catal: cataloguer of delila libraries, the catalogue program

synopsis
      catal(catalp: in,
            l1: in, cat1: out, lib1: out,
            l2: in, cat2: out, lib2: out,
            l3: in, cat3: out, lib3: out,
            humcat: out, catin: out,
            output: out)

files
      catalp: parameters to control the program.

         first line:  the library dates are not changed if the first
         character is 'n' (no date modification) or 'b' (book source
         of library, dates are not to be changed).  otherwise the
         dates are advanced.

         second line:  docomments: If there is a second line, then if
         it begins with 'n' comments are suppressed.

         third line:  fromtoinst: If there is a second line, then the third line must exist
         If it begins with 'f' then the Delila instructions in catin will be in from-to form:

            get from 50 -0 to same +[piecelength-1];

      l1: the first input file of the library
      cat1: the first catalogue
      lib1: the first output library

      l2: the second input file of the library
      cat2: the second catalogue
      lib2: the second output library

      l3: the third input file of the library
      cat3: the third catalogue
      lib3: the third output library

      output: progress report and error messages

      humcat: the catalogue generated for humans.  it includes the names
         of things in the libraries and their coordinates.  humcat is quite
         wide so you will need a line-printer to print it.  alternatively
         you can use the split program.
      catin:  Catalog listing as delila instructions.  This is a set of Delila
	 instructions for grabbing each of the pieces in the library.  These
	 make it easy to start writing instructions.

description
      The catalogue program checks all the input libraries for correct
      structure.  Duplicated names are removed and a new set of library
      files is created, along with their catalogues for delila.  A catalogue
      is also generated for people to use.  Each new library is associated with
      one catalogue.  Under most circumstances this pair can be given to
      delila along with pairs created at different times.

documentation
      libdef (defines catal), delman.use.coordinates, delman.construction

see also
      dbbk.p loocat.p, delila.p, split.p

author
      Michael Aden and Thomas Schneider

bugs
      Not all checks on the library structure are made.  Some checks from
      libdef are now outdated or not done: p. 3.1 2 d, e, f, g and l.

technical notes
      The circumstances when a library-catalogue pair must not be used with
      another pair:  it is not possible for delila to check for two
      organisms with the same name that exist in different libraries.  In
      this case, run the two libraries through catal together to eliminate
      the ambiguity.  If this is not done, the results will be anomalous.

*)
(* end module describe.catal *)

(* history of changes to catal:
      from original concepts by thomas schneider 1979 october 28
      written 1980 june 10 by michael aden
      modified 1980 june 14 - thomas schneider
      modified 1980 june 22 - michael aden
         insertion of code to handle duplicate names.
      modified 1980 july 5 - michael aden
         correction in listing indentation
      modified 1980 december 23 - thomas schneider: rearrange file names
      modified 1981 march 23 - michael aden: insertion of standard halt
         as opposed to non-standard halt.
      modified 1982 july 12 - michael aden: change to take care of forward
         reference duplicate names. more error checking is now done.
      modified 1982 july 14 - thomas schneider: standard program format and
         documentation.  modules inserted.  name changes.
      modified 1982 july 17 - thomas schneider: unlimitln added,
         readline logic altered.
      modified 1982 aug 1 - 'problems encountered', errors to humcat, checkstar
      modified 1983 dec 15 - duplicate names start with *2 using global
         constant firstnumber.
      modified 1984 jan 26 - procedure dumpline cannot produce lines
         shorter than 2 characters.  this assures that delila is happy
         when reading the library, since delila assumes that there is
         at least one space following each '*'.
      modified 1992 sep 14 - output names are the same as delila uses.
         This is by far the most common use of the program - why fight it?
         old name     new name
         --------     --------
         newl1        lib1
         newl2        lib2
         newl3        lib3
         c1           cat1
         c2           cat2
         c3           cat3
      modified 1994 March 4 - The humin file is introduced.
      modified 1994 April 7 - The humin file is renamed catin.

      1995 Nov 21:  Catal objected to a 1 base long piece, "coordinate
      beginning must be less than ending" This should be "less than or equal
      to".  "as required by libdef catalogue definition p. 3.1 2h" Libdef was
      also modified.

      1995 Dec 8:  Routine checkstar is modified so that it allows the
      fullname to be empty.  This allows the new <NAME> feature of Delila
      (see libdef) to give a blank when no name is assigned.

      1999 March 18: made names have type name, like in delila (!)
         tightened humcat output.

technical notes:
      l1, l2, ... numlibfil = the files of the old library
      c1, c2, ... numcatfil = the files of the new catalog for the librarian
      lib1, lib2, ... numcatfil = the files of the new library
      humcat = the catalog for humans
      catalp = a file used to set catalog parameters.
         the library dates are not modified if the first character
         is 'n' (no date modification) or
            'b' (book source of library, dates not to be changed)
      output = progress report and error messages


   the catalog program checks to see that the library
  is in proper format and checks to see that the names in each
  classification are unique .
     the catalog also generates:
(1) new library files
(2) a catalog for the librarian
(3) a human-readable catalog.

      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
         catalog files: numcatfil

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


problems encountered and resolved during delila catalog implementation

problem 1.
      duplicate entry names for any two of a given type of structure
      (e.g., two transcripts with the same name) may not necessarily
      be fatal (as in a library of transcripts, which may have dup-
      licate names after being pulled out).

resolution 1.
      duplicate names are changed and a warning is issued.

problem 2.
      if a piece name duplicates a previous piece name, it is not
      sufficient to change only the second piece name, since that
      piece may have had prior references made to it.

resolution 2.
      a list of pieces is started using the name of each piece
      reference encountered in transcripts, genes, etc.
      it was decided to conform to a strict familial structure
      which requires that only one piece reference may be active
      at any given time; (i.e., before going on to a new piece
      reference, a piece for the existing reference must first be
      encountered).

      consider the following structure:

transcript
* transcript1
* ...
* piece1
.
.
.
transcript
transcript
* transcript2
* ...
* piece1
.
.
.
piece
* piece1
.
.
.
piece
piece
* piece1
.
.
.

      note that if strict family ordering was not observed, it would
      be impossible to tell which piece each of the transcripts made
      a reference to.

*)

(* more constants *)
      debugging = false; (* flag for selective writes  *)
      verbose = false; (* control for all those long lists produced
         by the dumplists procedure *)
      namelength = 200; (* maximum key name length *)
      linelength = 210; (* maximum line readable in the library *)
{zzz}
      namespace = 15; (* maximum length for printing name on humcat *)
      numlibfil = 3; (* number of library files lll *)
      numcatfil = 3; (* number of catalog files ccc *)
      pagesize = 60; (* page size for human catalog *)
      listingwidth = 60; (* humcat listing width *)
{was 130}

      specialchar = '*' ; (* separator between original part of a name
                            and part added for uniqueness *)

      levelsize = 1; (* the number of spaces to indent for a level
                        of the library *)

      (* field sizes of data for humcat *)
      datafield = 110; (* the last character before fields of data
                         are printed *)
      bfield = 10; (* for basepairs *)
      cfield =  9; (* for coordinates *)
      dfield =  5; (* for directions *)
      nfield =  8; (* for numbers *)
   (* pfield = see variables and initialization *)
   (* todatafield = ' ' ' ' *)

      firstnumber = '2'; (* when a duplicate name is found the first time,
         this number is tacked on to the end.  the number '2' is recommended
         because it is the second name found. *)

(* begin module datetime.const *)

   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 = 1.17; (@ of timegpc.p 2002 Oct 9 *)

(* *********************************************************************)
type

(* begin module datetime.type *)
   (* array for dates *)
   datetimearray = packed array[1..datetimearraylength] of char;
(* end module datetime.type version = 1.17; (@ of timegpc.p 2002 Oct 9 *)

      alpha = packed array [1..namelength] of char;

      (* types defined in library definition *)

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

      (* catalog types *)

      calltype = (firstpage, chromosome, dna, enzyme, gene, library,
                  marker, organism, piece, recognitionclass, transcript);
          (* routines which may invoke a non-fatal error *)

      errtype = (cooconfigurationbad, coordirectionbad,
            coordbeginningbad, coordendingbad,
            pieconfigurationbad, piedirectionbad,
            piebeginningbad, pieendingbad,
            refdirectionbad, refbeginningbad, refendingbad,
            genebeginning, geneending, mapbeginning, maplocation,
            nolastpiece, noreference, wrongreference);
         (* non-fatal type errors *)

      item = record (* an item in the catalog *)
         letter: char; (* type of structure *)
         nam: name; (* the structure"s key name *)
         line: integer (* location of the structure in the library *)
      end;

      catfile = file of item;


      (* types defined for the catalog program *)
      buffer = packed array [1..linelength] of char;
{zzz}

      listptr = ^namandlistptr;

      namandlistptr = record
         nam: name;
         nextonlist: listptr
      end;

      currvals = record (* used for maintaining a list of names *)
         marker: namandlistptr;
         transcript: namandlistptr;
         gene: namandlistptr;
         piece: namandlistptr;
         chromosome: namandlistptr;
         enzyme: namandlistptr;
         organism: namandlistptr;
         recognition: namandlistptr
      end;

      nextref = ^refnode;

direction = (plus, minus);
configuration = (linear, circular);

pieceinfo = record     (* info about numbering of a piece *)
   config: configuration;
   direct: direction;
   beginning: integer;
   ending: integer
end;

      refnode = record     (* record containing information
                             for a piece reference *)
                 nodetype: (markref, transref, generef);
                 nodename: name;
                 nodedir: direction;
                 nodebeg: integer;
                 nodeend: integer;
                 nodenext: nextref
                end;

(* *********************************************************************)
var

      catalp: text;
         (* catalog parameters.  used to decide how to handle dates
            see var keepdates *)
      keepdates: boolean; (* false: advance dates in library
                             true:  do not advance dates since date of
                             creation is date of book creation by the
                             librarian. keepdates is set in initialize-
                             catalogs from catalp. *)
      docomments: boolean; (* write comments to the inst file *)
      fromtoinst: boolean; (* use the from-to format for the inst file *)
{zq}

      catitem: item;
{
      OLD NAMES:
      c1, c2, c3: catfile;       (* catalog files ccc *)
}
      cat1, cat2, cat3: catfile;       (* catalog files ccc *)

      catnumber: integer;  (* catalog number *)

      humcat: text;                 (* human readable catalog listing *)
      catin: text;                  (* catalog listing as delila instructions *)
      humcatpage,                    (* current page of listing *)
      humcatlines: integer;          (* current line on that page *)

      current, first: currvals;      (* values for names so far..
                                        first has pointers to lists of names
                                        for each classification.   *)

      freelistptr: listptr;         (* a list of free links *)
      latest: listptr;              (* points to a name *)

      l1, l2, l3: text;               (* old library files lll *)
{
      OLD NAMES:
      newl1, newl2, newl3: text;    (* new library files lll *)
}
      lib1, lib2, lib3: text;    (* new library files lll *)
                                    (* new library files *)
      libdone: boolean;             (* set if old library file has hit
                                        eof *)
      libline,                       (* current line in old library *)
      libnumber: integer;           (* number of current library *)

      level: integer;               (* levels deep in our structure-
                                        used for indentation purposes *)

      unique: boolean;              (* set to false if duplicate name in any
                                        one family is encountered.   *)

      daytime: datetimearray;       (* holds date and time in one
                                        variable. *)
      none: name;                   (* for clearing out names *)
      aname: name;                  (* a name which is pulled out of
                                        buffer *)
      toolong: boolean;             (* set if the name is too long to
                                        change *)
{zzz}
      line: buffer;                 (* buffer holding the current line *)
      length: integer;              (* current length of the line *)

      uniquebeg: integer;             (* point where we start to change a
                                         name. *)
      maxinteger: integer;             (* largest integer available on
                                          this machine *)
   (* maxreal: real; *)                (* largest real available on this
                                           machine.  This is not
         necessary to do and only causes trouble.  TDS *)
      basecount: integer;              (* number of bases for the current
                                         piece *)

      piecename: name;                (* name of currently referenced
                                         piece *)
      changed: boolean;               (* set if the current piece name is now
                                         different *)
      newpiecename: name;            (* new name of currently referenced
                                         piece *)

      piecefound: boolean;            (* set if the piece for the current
                                        reference has been found yet *)

      newnamelength: integer;       (* newname length for a changing name *)

      coo, pie: pieceinfo;            (* info about the numbering system *)

      pieceref: refnode; (* reference information for a transcript, gene,
                                or piece *)
      refroot: nextref; (* root of piece reference list *)

      fatal: integer; (* a count of errors found that prevent making
                       a new library, but not expected to snow ball *)

      pfield: integer; (* fields involved in piece info.  see constants *)
      todatafield: integer; (* the number of blanks to get to the
                               beginning of the data fields in humcat *)

      mapbeg, mapend: real; (* the genetic map range, read by mapbegend *)

      titlewritten: boolean; (* false until we have written the title.
         This prevents multiple titles from being written to catin in
         procedure writehumcat.  *)

   maxnamelength: integer; (* maximum name length found *)
(* replace namespace with this? *)

(* *********************************************************************)
(* *********************************************************************)
(* error halt procedure ************************************************)

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


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

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

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

(* error-handling procedures ******************************************)
procedure erroratline;
(* indicate to both humcat, catin and output that there was an error
in the current line of the library.  note that the actual libarary
line number is pred(line).  (crazy, i know.) *)
begin (* erroratline *)
      writeln(humcat); (* get off the humcatline *)
      writeln(humcat, ' error *********************************************');
      writeln(humcat, ' at line ', (libline-1):1, ' in file ', libnumber:1);
      humcatlines := humcatlines + 3;
      writeln(output, ' *** error at line ', (libline-1):1,
                     ' in file ', libnumber:1);
      writeln(catin, ' *** error at line ', (libline-1):1,
                     ' in file ', libnumber:1)
end; (* erroratline *)

procedure error(indicator: errtype);
(* this procedure flags errors in piece referencing by
   markers, transcripts, and genes. it also as a result
   checks the ordering of families, with the stipulation
   that all references to a piece must be made before the
   piece is found, with only one active forward reference
   at any given time. if no references are made to a piece
   by the time that piece is found, then a warning will be
   issued. all of these warnings are non-fatal, with
   the checking continuing after the flagged error.
      note: one line of error text is counted at the end of the procedure;
   additional lines are counted separately.
*)
var
   dummy: integer; (* throwaway for catin since position in catin
      does not matter *)
procedure message(var thefile: text; var filelines: integer);
(* put the message to the file, increment filelines *)
begin (* error *)
      case indicator of
         mapbeginning: begin
            writeln(thefile, ' in map beginning');
         end;
         maplocation: begin
            writeln(thefile,' genetic map location must be in the map [',
                             mapbeg:5:2,', ',mapend:5:2,']')
         end;
         cooconfigurationbad: begin
            writeln(thefile, ' coordinate configuration must be ',
                           ' either linear or circular.');
         end;
         coordirectionbad: begin
            writeln(thefile, ' coordinate direction must be a ',
                  '''+'' or a ''-''.');
         end;
         coordbeginningbad: begin
            writeln(thefile, ' coordinate beginning must be an integer');
         end;
         coordendingbad: begin
            writeln(thefile, ' coordinate ending must be an integer.');
         end;
         pieconfigurationbad: begin
            writeln(thefile, ' piece configuration must be ',
               'either linear or circular.');
         end;
         piedirectionbad: begin
            writeln(thefile, ' piece direction must be a ''+'' or a ''-''.');
         end;
         piebeginningbad: begin
            writeln(thefile, ' beginning piece coordinate must be an integer');
         end;
         pieendingbad: begin
            writeln(thefile, ' ending piece coordinate must be an integer');
         end;
         refdirectionbad: begin
            writeln(thefile, ' direction must be a ''+'' or a ''-''.');
         end;
         refbeginningbad: begin
            writeln(thefile, ' nucleotide beginning must be an integer.')
         end;
         refendingbad: begin
            writeln(thefile, ' nucleotide ending must be an integer.')
         end;
         genebeginning: begin
            writeln(thefile, 'in gene beginning ');
            writename(thefile, current.gene.nam);
            writeln(thefile);
         end;
         geneending: begin
            writeln(thefile, 'in gene ending ');
            writename(thefile, current.gene.nam);
            writeln(thefile);
         end;
         nolastpiece: begin
            writeln(thefile, ' error in family structure.');
            write(thefile, ' reference was made to a new piece: ');
            writename(thefile,aname);
            writeln(thefile);
            write(thefile, ' while a piece previously referenced: ');
            writename(thefile,piecename);
            writeln(thefile, ' was still unfound.');
            filelines := filelines + 3
         end;
         noreference: begin
            write(thefile, ' caution: no reference was',
                           ' previously made to this piece: ');
            writename(thefile,aname);
            writeln(thefile);
            writeln(output, ' (this is a warning: unreferenced piece)');
            filelines := filelines + 1
         end;
         wrongreference: begin
            writeln(thefile, ' error in family structure.');
            write(thefile, ' piece ');
            writename(thefile,aname);
            write(thefile, ' was encountered while a',
                           ' reference to piece ');
            writename(thefile, piecename);
            writeln(thefile, ' was still active.');
            filelines := filelines + 1
         end;
      end;

      if indicator in [cooconfigurationbad..pieendingbad] then begin
         write(thefile, ' in piece ');
         writename(thefile, current.piece.nam);
         writeln(thefile);
         filelines := filelines + 1
      end;

      if indicator in [refdirectionbad..refendingbad] then begin
         write(thefile, ' error found in reference',
                        ' to piece ');
         writename(thefile,piecename);
         writeln(thefile);
         write(thefile, ' by ');
         case pieceref.nodetype of
            markref:  write(thefile, 'marker');
            generef:  write(thefile, 'gene');
            transref: write(thefile, 'transcript');
         end;
         writeln(thefile, ' ');
         writename(thefile, pieceref.nodename);
         writeln(thefile);

         filelines := filelines + 2;
      end;

         (* determine fatality *)
      if not (indicator in [noreference])
      then fatal := succ(fatal);

      (* count at least one error line and the following blank line: *)
      filelines := filelines + 2;
      writeln(thefile)
end;
begin
   erroratline;
   message(humcat, humcatlines);
   message(catin, dummy);
end; (* error *)

procedure strange(callingproc: calltype);
   (* give message on strange structure and abort *)
begin (* strange *)
   write(output, ' ''', line[1], ''' found at line ', (libline - 1):1,
                ' in library no. ', libnumber:1, ' where');
   case callingproc of
      firstpage:        write(output, ' (firstpage)');
      marker:           write(output, ' an m');
      transcript:       write(output, ' a t');
      gene:             write(output, ' a g');
      piece:            write(output, ' a p');
      chromosome:       write(output, ' a c, m, t, g, or p');
      enzyme:           write(output, ' an e or an s');
      recognitionclass: write(output, ' an r or an e');
      organism:         write(output, ' an o or a c');
      library:          write(output, ' an o or an r');
      dna:              write(output, ' a d')
   end;
   writeln(output, ' was expected.');
   halt
end; (* strange *)

(* help procedures **************************************************)

procedure docathelp (var h: text);
(* help the user *)
begin (* docathelp *)
writeln(h,' All of the libraries were empty!');
writeln(h,' Usage of catal ',version:4:2,':');
writeln(h,' catal(humcat,catalp,l1,c1,newl1,l2,c2,newl2,l3,c3,newc3,output)');
writeln(h,' The catal program is used to check the format of one or more');
writeln(h,' libraries and to build catalogues corresponding to them.');
writeln(h,' It also produces a catalogue for humans, the humcat.');
writeln(h,' and Delila instructions in catin.');
writeln(h,' See delman for further help.');
end; (* of docathelp *)

(* *********************************************************************)
(* list dumping procedures ******************************************)

procedure traversealist(var the: listptr);
(* write out each name in a list *)
begin
   if the <>nil
      then begin
         write(output, '  ');
         writename(output,the^.nam);
         writeln(output);
         traversealist(the^.nextonlist)
         (* do the rest of the list *)
      end
end; (* traversealist *)

procedure dumplists;
(* dump all of the names on each list up to now for this family.*)
begin (* dumplists *)

if verbose then begin

   writeln(output, ' lists at time of error:');

   (* print out the list of recognition -classes, starting at the
      root of the list. this is done by the traversealist procedure.*)
   writeln(output, ' recognition-class names');
   traversealist(first.recognition.nextonlist);

   (* list of enzyme names for the current recognition-class *)
   writeln(output, ' enzyme names for the current recognition-class');
   traversealist(first.enzyme.nextonlist);

   (* list of organism names *)
   writeln(output, ' organism names');
   traversealist(first.organism.nextonlist);

   (* list of chromosome names for the current organism *)
   writeln(output, ' chromosome names for the current organism');
   traversealist(first.chromosome.nextonlist);

   (* list of markers for the current chromosome *)
   writeln(output, ' marker names for the current chromosome');
   traversealist(first.marker.nextonlist);

   (* lists of transcript names for current chromosome *)
   writeln(output, ' transcript names for current chromosome');
   traversealist(first.transcript.nextonlist);

   (* lists of gene names for current chromosome *)
   writeln(output, ' gene names for the current chromosome');
   traversealist(first.gene.nextonlist);

   (* lists of piece names for the current chromosome *)
   writeln(output, ' piece names for the current chromosome');
   traversealist(first.piece.nextonlist)
end (* of the verbose if *)
end; (* dumplists *)

(* *********************************************************************)
(* date-handling procedures*******************************************)

(* begin module package.datetime *)
(* ************************************************************************ *)
(* begin module getdatetime *)
procedure getdatetime(var adatetime: datetimearray);
(* 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).
As of 2000 February 18, the Sun Pascal compiler requires a formatting
statement.  This statement allows the date to be generated in this
standard Delila format in a single call.  Information about the
formatting statement is available on the manual page for date in Unix.
If a computer does not have this method, see the 'oldgetdatetime' routine
in delmod.p (https://alum.mit.edu/www/toms/delila/delmod.html)
for some conversion code.

GPC Functions:
function  GetUnixTime (var MicroSecond : Integer) : UnixTimeType;

http://agnes.dida.physik.uni-essen.de/~gnu-pascal/gpc_109.html#SEC109

7.10.8 Date And Time Routines 

procedure GetTimeStamp (var t : TimeStamp); 
function Date (t : TimeStamp) : packed array [1 .. DateLength] of Char; 
function Time (t : TimeStamp) : packed array [1 .. TimeLength] of Char; 

DateLength and TimeLength are implementation dependent constants. 

GetTimeStamp (t) fills the record `t' with values. If they are valid, the Boolean
flags are set to True. 

TimeStamp is a predefined type in the Extended Pascal standard. It may be
extended in an implementation, and is indeed extended in GPC. For the full
definition of `TimeStamp', see section 8.255 TimeStamp. 

*)
var
    t: TimeStamp; 

(* begin module pluckdigit *)
function pluckdigit(number, logplace:integer): char;
(* return the digit at the place value ('logplace') position of number.
example:
      pluckdigit(13625, 3) = 3
      pluckdigit(13625, 4) = 1
This routine was taken from module numberdigit in prgmod.p, but is
modified so as not to give the sign.  Instead it gives zeros
above the digits.  'myabsolute' replaced 'absolute', which
is apparently a keyword for GPC.  The name is kept for
to keep the code looking similar to its origin.
*)
var
      place: integer; (* the exponent of logplace *)
      count: integer; (* used to make place *)
      myabsolute: integer; (* the absolute value of number *)
      acharacter: char; (* the character to be returned *)
procedure digit;
(* extract a digit at the place position *)
var
      tenplace: integer; (* ten times place *)
      z: integer; (* an intermediate value *)
      d: integer; (* the digit extracted *)
begin (* digit *)
      tenplace:=10*place;
      z:=myabsolute-((myabsolute div tenplace)*tenplace);
      if place = 1
         then d:=z
         else d:= z div place;
      case d of
         0: acharacter:='0';
         1: acharacter:='1';
         2: acharacter:='2';
         3: acharacter:='3';
         4: acharacter:='4';
         5: acharacter:='5';
         6: acharacter:='6';
         7: acharacter:='7';
         8: acharacter:='8';
         9: acharacter:='9';
      end
end; (* digit *)
begin (* pluckdigit *)
      place:=1;
      for count:=1 to logplace do place:=10*place;
      if number=0 then begin
         acharacter:='0'
      end
      else begin
         myabsolute:=number;
         if myabsolute >= place
         then digit
         else acharacter := '0'
      end;
      pluckdigit:=acharacter
end; (* pluckdigit *)
(* end module pluckdigit *)

begin

 (* according to:
http://agnes.dida.physik.uni-essen.de/~gnu-pascal/gpc_109.html#SEC109
*)
   GetTimeStamp(t); 

(* Predefined time stamp:
http://agnes.dida.physik.uni-essen.de/~gnu-pascal/gpc_389.html#SEC389
  TimeStamp = {@@packed} record
      DateValid,
      TimeValid   : Boolean;
      Year        : Integer;
      Month       : 1 .. 12;
      Day         : 1 .. 31;
      DayOfWeek   : 0 .. 6;  { 0 means Sunday }
      Hour        : 0 .. 23;
      Minute      : 0 .. 59;
      Second      : 0 .. 61; { to allow for leap seconds }
      MicroSecond : 0 .. 999999
    end;
*)

  with t do begin
    if TimeValid then begin
{
       writeln(output,'valid time');
       writeln(output,'year   =',year:4);
       writeln(output,'month  =',month:2);
       writeln(output,'day    =',day:2);
       writeln(output,'hour   =',hour:2);
       writeln(output,'minute =',minute:2);
       writeln(output,'second =',second:2);
}
       adatetime := 'year/mm/dd hh:mm:ss';
       adatetime[ 1] := pluckdigit(Year,3);
       adatetime[ 2] := pluckdigit(Year,2);
       adatetime[ 3] := pluckdigit(Year,1);
       adatetime[ 4] := pluckdigit(Year,0);
       adatetime[ 6] := pluckdigit(Month,1);
       adatetime[ 7] := pluckdigit(Month,0);
       adatetime[ 9] := pluckdigit(Day,1);
       adatetime[10] := pluckdigit(Day,0);
       adatetime[12] := pluckdigit(Hour,1);
       adatetime[13] := pluckdigit(Hour,0);
       adatetime[15] := pluckdigit(Minute,1);
       adatetime[16] := pluckdigit(Minute,0);
       adatetime[18] := pluckdigit(Second,1);
       adatetime[19] := pluckdigit(Second,0);
    end
    else begin
       writeln(output,'getdatetime: invalid time!');
       halt;
    end
  end;
{
   Sun compiler method:
   date(adatetime,'%Y/%m/%d %H:%M:%S');
}
end;
(* end module getdatetime version = 1.17; (@ of timegpc.p 2002 Oct 9 *)

(* begin module readdatetime *)
procedure readdatetime (var thefile: text; var adatetime: datetimearray);
(* read the date and time from the file.  It must have this format:
123456789 123456789
         1         
1980/06/09 18:49:11
 *)
(*
2001 Jan 2: thefile is not written to!  Force 4 digit years.
2000 Oct 11: upgraded so that the p2c compiler does not object
to writing out the adatetime; added checks for the date.
*)
var
   index: integer; (* 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 *)
   udatetime: array[1..datetimearraylength] of char;
begin
   for index:=1 to datetimearraylength do read(thefile,udatetime[index]);
   pack(udatetime, 1, adatetime);
   if (adatetime[3]='/') and (adatetime[12]=':') then begin
      writeln(output,'You have an old datetime (only 2 year digits): ');
      for index:=1 to datetimearraylength do write(output,adatetime[index]);
      writeln(output);
      writeln(output,'Convert your database to 4 digit years.');
      halt;
   end;
   (* check the adatetime format.  Note that further checks for the
      other positions in the array could be done to be sure that
      they are numbers.  But this should be pretty good. *)
   if (adatetime[ 5]<>'/') or
      (adatetime[ 8]<>'/') or
      (adatetime[14]<>':') or
      (adatetime[17]<>':')
   then begin
      writeln(output,'readdatetime: bad date time read:');
      for index:=1 to datetimearraylength do write(output,adatetime[index]);
      writeln(output);
      halt
   end;
end;
(* end module readdatetime version = 1.17; (@ of timegpc.p 2002 Oct 9 *)

(* begin module writedatetime *)
procedure writedatetime(var thefile: text; adatetime: datetimearray);
(* expand the date and time out and print in the file *)
var
      index: integer; (* index of datetime *)
begin
      for index:=1 to datetimearraylength do write(thefile,adatetime[index])
end;
(* end module writedatetime version = 1.17; (@ of timegpc.p 2002 Oct 9 *)

(* begin module timeseed *)    
(* 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.  This
has the nice property that the seed changes every second and does not repeat
for thousands of years!  *)
procedure addtoseed(var seed, power: real; c: char);
(* add the digit represented by c to the seed at the power position *)
var
      n: integer; (* the character represented by c *)
begin (* addtoseed *)
      power := power/10;
{
writeln(output,'addtoseed, c = ',c);
writeln(output,'addtoseed, ord(c) = ',ord(c));
}
   n := ord(c) - ord('0');
   if (n < 0) or (n > 9) then begin
      writeln(output,'timeseed: error in datetime');
      writeln(output,'it contains "',c,'" which is not a number.');
      writeln(output,'The getdatetime routine must be fixed.');
      halt;
   end;
   seed := seed + power*n
end; (* addtoseed *)

procedure makeseed(adatetime: datetimearray; var seed: real);
(* convert adatetime to a real number in seed, reversed order
Here is the standard adatetime format:
123456789 123456789
         1         
1980/06/09 18:49:11
*)
var
   power: real; (* a digit of the seed such as 0.01 *)
begin
   seed := 0.0;
   power := 1.0;
   addtoseed(seed, power, adatetime[19]);
   addtoseed(seed, power, adatetime[18]);
   (* : *)
   addtoseed(seed, power, adatetime[16]);
   addtoseed(seed, power, adatetime[15]);
   (* : *)
   addtoseed(seed, power, adatetime[13]);
   addtoseed(seed, power, adatetime[12]);
   (*   *)
   addtoseed(seed, power, adatetime[10]);
   addtoseed(seed, power, adatetime[ 9]);
   (* / *)
   addtoseed(seed, power, adatetime[ 7]);
   addtoseed(seed, power, adatetime[ 6]);
   (* / *)
   addtoseed(seed, power, adatetime[ 4]);
   addtoseed(seed, power, adatetime[ 3]);
   addtoseed(seed, power, adatetime[ 2]);
   addtoseed(seed, power, adatetime[ 1]);
end;

procedure orderseed(adatetime: datetimearray; var seed: real);
(* convert adatetime to a real number in seed, normal order *)
var
   power: real; (* a digit of the seed such as 0.01 *)
begin
   seed := 0.0;
   power := 1.0;
   addtoseed(seed, power, adatetime[ 3]);
   addtoseed(seed, power, adatetime[ 4]);
   addtoseed(seed, power, adatetime[ 6]);
   addtoseed(seed, power, adatetime[ 7]);
   (* / *)
   addtoseed(seed, power, adatetime[ 9]);
   addtoseed(seed, power, adatetime[10]);
   (* / *)
   addtoseed(seed, power, adatetime[12]);
   addtoseed(seed, power, adatetime[13]);
   (*   *)
   addtoseed(seed, power, adatetime[15]);
   addtoseed(seed, power, adatetime[16]);
   (* : *)
   addtoseed(seed, power, adatetime[18]);
   addtoseed(seed, power, adatetime[19]);
end;

procedure timeseed(var seed: real);
(* 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. *)
var
   adatetime: datetimearray; (* a date and time *)
begin (* timeseed *)
   getdatetime(adatetime);
{
writeln(output,'timeseed: adatetime: ',adatetime);
}
   makeseed(adatetime, seed);
end; (* timeseed *)
(* end module timeseed version = 1.17; (@ of timegpc.p 2002 Oct 9 *)
 
(*[[*)
(* begin module limitdate *)
procedure limitdate(a,b,c,d: char; limitdatetime: datetimearray);
(* test whether the current time is before the limit.
If it is later, halt the program *)
var
   adatetime: datetimearray; (* a date and time *)
   Dday: real; (* the critical day *)
   now: real;  (* this very moment *)
begin
   getdatetime(adatetime);
{
writeln(output,'adatetime:',adatetime);
writeln(output,'adatetime[1]: ', adatetime[1]);
writeln(output,'adatetime[2]: ', adatetime[2]);
writeln(output,'adatetime[3]: ', adatetime[3]);
writeln(output,'adatetime[4]: ', adatetime[4]);
writeln(output,'adatetime[5]: ', adatetime[5]);
}

   orderseed(adatetime, now);

   if
      (limitdatetime[1] <> ' ') or
      (limitdatetime[2] <> ' ') or
      (limitdatetime[3] <> ' ') or
      (limitdatetime[4] <> ' ') then halt;

   limitdatetime[1] := a;
   limitdatetime[2] := b;
   limitdatetime[3] := c;
   limitdatetime[4] := d;

   orderseed(limitdatetime, Dday);

{
   writeln(output,'now:  ',now:20:10);
   writeln(output,'Dday: ',Dday:20:10);
}
   if now > Dday then begin
       writeln(output,'This program expired on ',limitdatetime);
       writeln(output,'See: https://alum.mit.edu/www/toms/walker/contacts.html');
       halt
   end
end;
(* end module limitdate version = 1.17; (@ of timegpc.p 2002 Oct 9 *)
(*]]*)

(* ************************************************************************ *)
(* end module package.datetime version = 1.17; (@ of timegpc.p 2002 Oct 9 *)

(* *********************************************************************)
(* opening and closing procedures*************************************)

procedure maxnum(var maxreal:real);
(* this procedure calculates the largest real number
  possible on this machine.
   this procedure assumes the range of numbers is somewhat
  balanced to either side of 1 (i.e., 2^-n< 1 < 2^n , approximately )
  The routine doesn't work too well with using 1/lastsmall because
  dividing by such a small number produces infinity on a Sun workstation.
  Using the small number before that one (prelastsmall) avoids the
  difficulty.  HA!  NO IT DOESN'T!!!  Even preprelastsmall still
  causes overflow.  Drop it!  Who cares?
*)
var
   small, (* a small real number *)
   lastsmall, (* the small real number before small *)
   prelastsmall, (* the small real number before lastsmall *)
   preprelastsmall: (* the small real number before prelastsmall *)
     real;
begin
   small := 1;
   while small <> 0
     do begin
       preprelastsmall := prelastsmall;
       prelastsmall := lastsmall;
       lastsmall := small;
       small := small/10
;writeln(output,'maxnum: small = ',small:10);
   end;
   maxreal := 1/preprelastsmall
;writeln(output,'maxnum: lastsmall = ',lastsmall:10);
;writeln(output,'maxnum: prelastsmall = ',prelastsmall:10);
;writeln(output,'maxnum: preprelastsmall = ',preprelastsmall:10);
;writeln(output,'maxnum: maxreal = ',maxreal:10);
end;

(* begin module copyaline *)
procedure copyaline(var fin, fout: text);
(* copy a line from file fin to file fout *)
begin (* copyaline *)
      while not eoln(fin) do begin
         fout^ := fin^;
         put(fout);
         get(fin)
      end;
      readln(fin);
      writeln(fout);
end; (* copyaline *)
(* end module copyaline version = 7.62; {of delmod.p 2003 Jan 13} *)

procedure reportparent(var l: text);
(* report the parantage of the library (if it exists) *)
begin
   reset(l);
   if not eof(l) then begin
      reset(l);
      copyaline(l, humcat);
      humcatlines := succ(humcatlines);

      reset(l);
      copyaline(l, catin);
      reset(l);
   end;
end;

function countlibrary(var l: text): integer;
(* provide 0 if the library is empty and 1 if it is not *)
begin
  reset(l);
  if eof(l)
  then countlibrary := 0
  else countlibrary := 1
end;

procedure dopage;
(* start a page *)
begin (* dopage *)
   if humcatpage <> 0 then begin
      page(humcat);
      humcatlines := 0
   end;
   humcatpage := succ(humcatpage);
   write(humcat,'catal ',version:4:2);
   write(humcat,' - Catalogue listing of ');
   writedatetime(humcat, daytime);
   write(humcat,' page ',humcatpage:1);
   writeln(humcat);
   if not titlewritten then begin
      write(catin,'title "Delila instructions for library ');
      writedatetime(catin, daytime);
      writeln(catin,'";');
      write(catin,'(* catal ',version:4:2,' *)');
      writeln(catin);
      titlewritten := true
   end;
end;

procedure initializecatalogs(var catalp: text; var c1,c2,c3: catfile);
var
      i: integer;
      ch: char; (* reading character *)
begin (* initializecatalogs *)
      (* get largest numbers *)
      (* maxnum(maxreal);  unnecessary. *)

      (* read catalog parameters *)
      reset(catalp);
{
   if docomments then begin
}
      docomments := true;
      fromtoinst := false;
{zq}
      if eof(catalp)
      then keepdates:=false (* the default *)
      else begin
         readln(catalp, ch);
         if ch in ['n', 'b'] then keepdates:=true
                             else keepdates:=false;

         if not eof(catalp) then begin
            if catalp^ = 'n'
            then docomments := false;
            readln(catalp);
         end;

         if not eof(catalp) then begin
            if catalp^ = 'f'
            then fromtoinst := true;
            readln(catalp);
         end;

      end;
      write(output, ' library dates ');
      if keepdates then writeln(output, 'kept')
                   else writeln(output, 'advanced');

      (* initialize the catalog files ccc *)
      rewrite(c1);
      rewrite(c2);
      rewrite(c3);

      rewrite(humcat);
      rewrite(catin);
      humcatlines := 0;
      humcatpage := 0;

      titlewritten := false;
      dopage;

      writeln(humcat); humcatlines := succ(humcatlines);
      write(humcat,'parent librar');
      if countlibrary(l1)
       + countlibrary(l2)
       + countlibrary(l3) > 1
      then write(humcat,'ies')
      else write(humcat,'y');
      writeln(humcat,': '); humcatlines := succ(humcatlines);
      if docomments then begin
         writeln(catin,'(* parent library: ');
         reportparent(l1);
         reportparent(l2);
         reportparent(l3);
         writeln(catin,' *)');
      end;

      libnumber := 1;
      catnumber := 1;
      for i := 1 to namelength do none.letters[i] := ' ';
      piecename := none;
      piecefound := false;
      refroot := nil;
      with current do
         begin
            marker.nam := none;
            transcript.nam := none;
            gene.nam := none;
            piece.nam := none;
            chromosome.nam := none;
            enzyme.nam := none;
            recognition.nam := none;
            organism.nam := none
         end;

      (* reset the pointers to the lists of names to nil *)
      freelistptr := nil;
      with first do
         begin
            marker.nextonlist := nil;
            transcript.nextonlist := nil;
            gene.nextonlist := nil;
            piece.nextonlist := nil;
            chromosome.nextonlist := nil;
            enzyme.nextonlist := nil;
            recognition.nextonlist := nil;
            organism.nextonlist := nil
         end;

      (* how many blanks to print to get to the data field.
         see writehumcat) *)
{
old wide way:
      todatafield := datafield - (28 + namelength);
}
      todatafield := namespace;

      (* these are the fields of a coordinate system half *)
      pfield := cfield + dfield + 2*nfield;

      (* we will start this enterprise with an open mind: *)
      fatal := 0;

end; (* initializecatalogs *)

(* *********************************************************************)
(* library line read and write procedures *****************************)

procedure dumpline(var newlib: text; i: integer);
(* dump a line of length i to the new library.  if the line would be only
 one character long (just an '*'), then delila will have problems
 because it assumes that there is a space following each '*'.
 rather than slow down delila, we check for this case and add
 a space if there is none. *)
var j: integer;  (* index to the line *)
begin
   if (not libdone)
      then
         begin
               (* move the line into the new library file *)
            for j := 1 to i do write(newlib, line[j]);
            (* guarantee that all lines have at least two characters
               in order to keep delila happy *)
            if i = 1 then write(newlib,' ');
            writeln(newlib)
         end
end; (* of dumpline *)

procedure dumpitem(var cat: catfile; it: item);
(* dump an item to a cat *)
begin (* dumpitem *)
      cat^ := it;
      put(cat)
end; (* dumpitem *)

procedure readline(var lib:text; var length: integer);
(* read a line from the library into the global 'line' *)
var
      j: integer; (* index to line *)
      (* unpacked buffer line: *)
      uline: array[1..linelength] of char;
begin (* readline *)
      (* update line number at this point so that if there is an error,
         the correct line number will be given... *)
      libline := succ(libline);
      length := 0;

      if eof(lib)
      then libdone := true
      else begin (* if we still have a line then fill the buffer *)
         while (not eoln(lib)) and (length < linelength) do
         (* read line into a line buffer *)
            begin
               length := length+1;
               read(lib, uline[length])
            end;
            pack(uline, 1, line);

         (* fill the rest of the line buffer with blanks *)
         for j:=(length+1) to linelength do line[j] := ' ';

         if not eoln(lib) then begin
            erroratline;
            writeln(humcat, ' the line is longer than ',
                           linelength:1, ' characters');
            write(humcat, ' ');

            for j:=1 to linelength do write(humcat, line[j]);
            writeln(humcat);
            humcatlines := humcatlines + 2;

            if docomments then begin
               writeln(catin, ' the line is longer than ',
                              linelength:1, ' characters');
               write(catin, ' ');
               for j:=1 to linelength do write(catin, line[j]);
               writeln(catin);
            end;

            fatal := succ(fatal);
         end;

         if length = 0 then begin
            erroratline;
            writeln(humcat, ' blank line in library');
            writeln(catin, ' blank line in library');
            humcatlines := succ(humcatlines);
            fatal := succ(fatal);
         end;
         readln(lib);
      end;
end; (* readline *)

{
apparently newlib is not needed TDS 1992 sep 14
procedure needline(var lib, newlib:text;var length: integer);
}
procedure needline(var lib:text; var length: integer);
(* procedure needline is called when it is imperative that we get a new
      line, but do not want to dump it to the new library yet. *)
begin (* needline *)
      readline(lib, length);
      if libdone then begin
         erroratline;
         writeln(output, 'premature end of library file');
         halt
      end
end; (* needline *)

procedure needlibline(var lib, newlib:text;var length: integer);
(* needlibline is called when it is imperative that we get a line.
   it is then dumped to the catalog.  *)
begin (* needlibline *)
      needline(lib, {newlib,} length);
      dumpline(newlib, length)
end; (* needlibline *)

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

procedure checkstar(checkattribute: boolean);
(* check the star at the start of each line using the global 'line'.
If checkattribute is true, then not check for the existance of the attribute,
otherwise let it slide.  That allows one to use the Delila <NAME> function so
that unnamed objects get a blank name. *)
begin (* checkstar *)
      if length < 3 then begin
         if checkattribute then begin
            erroratline;
            writeln(humcat, ' attribute is missing');
            writeln(catin, ' attribute is missing');
            fatal := succ(fatal);
            humcatlines := humcatlines + 1
         end
      end
      else begin
         if line[1] <> '*' then begin
            erroratline;
            writeln(humcat, ' asterisk (*) missing from start of line');
            writeln(catin, ' asterisk (*) missing from start of line');
            fatal := succ(fatal);
            humcatlines := humcatlines + 1
         end;

         if line[2] <> ' ' then begin
            erroratline;
            writeln(humcat, ' blank missing from start of line');
            writeln(catin, ' blank missing from start of line');
            fatal := succ(fatal);
            humcatlines := humcatlines + 1
         end
      end
end; (* checkstar *)

procedure skipblanks({var lib: text;} var linepos: integer; var bad: boolean);
(* skip blanks on the global line, after the '* '.  this procedure is
absolutely required because some compilers (eg:
      digital vax/vms 3.0 pascal
but not
      dec cyber pascal
or    ibm personal computer pascal )
will put an extra blank in front of real numbers (but not integers...).
this happens even when one writes with a field size 1 (as re:1:2).
programs that write books (eg. makebk) therefore make bad books if catal
does not accept the blanks... subtle and silly.  *)
begin (* skipblanks *)
      linepos := 3; (* start after the star *)

      while (linepos <= length) and (line[linepos] = ' ')
         do linepos := succ(linepos);

      bad := (linepos > length)
end; (* skipblanks *)

procedure getinteger(var lib, newlib: text; var intnumber: integer;
                     var badtoken:boolean);
(* this procedure pulls an integer off the current input line
  and returns its value if valid. if a valid integer does not exist,
  badtoken returns a value true. otherwise, badtoken is false.
*)

var subtotal: integer;     (* value for the token so far *)
    linepos: integer;      (* position on line *)
    thesign: integer;    (* multiplier for sign *)
begin (* getinteger *)
   needlibline(lib, newlib, length);
   checkstar(true);
   skipblanks({lib,} linepos, badtoken);
   if not badtoken then begin
      subtotal := 0;
      if (line[linepos] in ['+', '-'])
         then
            begin
               if line[linepos] = '-'
                  then thesign := -1
                  else thesign := +1;
               linepos := succ(linepos)
            end
         else thesign := +1;
      while (linepos <= length) and (line[linepos] in ['0'..'9'])
            and (subtotal < (maxint div 10 -10)) do
         begin
            case line[linepos] of
               '0': subtotal := 10 * subtotal;
               '1': subtotal := 10 * subtotal + 1;
               '2': subtotal := 10 * subtotal + 2;
               '3': subtotal := 10 * subtotal + 3;
               '4': subtotal := 10 * subtotal + 4;
               '5': subtotal := 10 * subtotal + 5;
               '6': subtotal := 10 * subtotal + 6;
               '7': subtotal := 10 * subtotal + 7;
               '8': subtotal := 10 * subtotal + 8;
               '9': subtotal := 10 * subtotal + 9
               end; (* of case*)
            linepos := succ(linepos)
         end; (* of while loop *)
      if (linepos <= length) and (line[linepos] <> ' ')
         then badtoken := true
         else intnumber := subtotal;

         intnumber := thesign * intnumber;
   end;
   if badtoken then intnumber := 0
end; (* getinteger*)

procedure getreal(var lib, newlib: text; var realnumber: real;
                  var badtoken:boolean);
(* this procedure extracts a real number from the current input
  line, if one exists.if so, on exit, realnumber is the value
  of that real number;if not, badtoken is set to true.
*)
var subtotal: real;   (* total for the token so far *)
    linepos: integer; (* position on the input line *)
    pointfound: boolean; (* set if a decimal point has been found yet *)
    multiplier: real;    (* multiplier for this point in token *)
    thesign: integer;    (* multiplier for sign *)
begin (* getreal *)
   needlibline(lib, newlib, length);
   checkstar(true);
   skipblanks({lib,} linepos, badtoken);
   if not badtoken then begin
      multiplier := 1;
      pointfound := false;
      subtotal := 0;
      if (line[linepos] in ['+', '-'])
         then
            begin
               if line[linepos] = '-'
                  then thesign := -1
                  else thesign := +1;
               linepos := succ(linepos)
            end
         else thesign := +1;

      while (linepos <= length) and (line[linepos] in ['0'..'9', '.'])
(* this is not necessary and only causes trouble:
            and (subtotal < (maxreal/10 - 10))
*)
         do begin
            if line[linepos] = '.'
            then if pointfound (* was there a second decimal? *)
                 then badtoken := true
                 else pointfound := true
            else begin
               if pointfound
               then multiplier := multiplier/10
               else subtotal   := subtotal  *10;

               case line[linepos] of
                  '0': (* subtotal := subtotal *);
                  '1': subtotal := subtotal + (multiplier * 1);
                  '2': subtotal := subtotal + (multiplier * 2);
                  '3': subtotal := subtotal + (multiplier * 3);
                  '4': subtotal := subtotal + (multiplier * 4);
                  '5': subtotal := subtotal + (multiplier * 5);
                  '6': subtotal := subtotal + (multiplier * 6);
                  '7': subtotal := subtotal + (multiplier * 7);
                  '8': subtotal := subtotal + (multiplier * 8);
                  '9': subtotal := subtotal + (multiplier * 9)
               end
            end;
            linepos := succ(linepos)
         end;
      if ((linepos <= length) and (line[linepos] <>' ')) or (badtoken)
         then badtoken := true
         else realnumber := subtotal;

         realnumber := thesign * realnumber;
   end;

   if badtoken then realnumber := 0.0
end; (* getreal *)

procedure getconfig(var lib, newlib: text; var c: configuration;
                    var badtoken: boolean);
(* obtain a configuration and the line buffer *)
begin (* getconfig *)
      needlibline(lib, newlib, length);
      checkstar(true);
      badtoken := false;
           if line[3] = 'c' then c := circular
      else if line[3] = 'l' then c := linear
      else badtoken := true
end; (* getconfig *)

procedure getdirect(var lib, newlib: text; var d: direction;
                   var badtoken: boolean);
(* obtain a configuration from the line buffer *)
begin (* getdirect *)
      needlibline(lib, newlib, length);
      checkstar(true);
      badtoken := false;
           if line[3] = '-' then d := minus
      else if line[3] = '+' then d := plus
      else badtoken := true
end; (* getdirect *)


procedure getname;
(* pull a name out of the line buffer *)
var i, j: integer;
begin (* getname *)
   (* note that no needlibline is done, because of the way getname
      is used in changename.  changename is used in a loop in
      procedure duplicate... *)
   checkstar(true);
   i := 1;
   while (i<=namelength) and (line[i+2] <>' ')
            (* skip star and space in first two positions *)
      do
      begin
         aname.letters[i] := line[i+2];
         i := i+1
      end;
   aname.length := i-1;
   if maxnamelength < aname.length
   then maxnamelength := aname.length;
   j := i;
   while j <= namelength do
      begin
         (* fill character must be space to avoid trouble with delila *)
         aname.letters[j] := ' ';
         j := j + 1
      end;
   catitem.nam.length := i-1
   (* set length of name for the catalog *)
end; (* getname *)

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

procedure readlibdate(var lib, newlib:text; var c1,c2,c3: catfile);
   (* read a date into the first catalog and update the library date *)
var
      ch: char; (* a reading character *)
      i: integer; (* index for transfering the date to the name *)
      olddaytime: datetimearray;
begin (* readlibdate *)
      (* insert date in the new library *)
      write(newlib, '* ');
      read(lib, ch, ch); (* skip '* ' *)
      if keepdates
      then begin
         (* pick up daytime from library itself *)
         readdatetime(lib, daytime);
         (* put daytime right back ... *)
         writedatetime(newlib, daytime);
         (* and copy rest of line (below) *)
      end
      else begin
         (* new date *)
         writedatetime(newlib, daytime);

         (* copy old date into second position in newlib *)
         write(newlib, ', ');
         readdatetime(lib, olddaytime);
         writedatetime(newlib, olddaytime);

         (* skip second date of oldlib *)
         read(lib, ch, ch);
         readdatetime(lib, olddaytime);
      end;

      (* copy name of library (or rest of header if keepdates = true) *)
      while not eoln(lib) do begin
         read(lib, ch);
         write(newlib, ch)
      end;
      writeln(newlib);

      writeln(output);
      write(output, ' library ', libnumber:1, ' date will be: ');
      writedatetime(output, daytime);
      writeln(output);

      (* set up the first item of the catalog *)
      with catitem do
         begin
            letter := '*';
            nam.length := datetimearraylength; (* corrected 2001 Mar 16 *)
{
            nam.letters := daytime;
            for i := 1 to namelength
}
            for i := 1 to nam.length
            do nam.letters[i] :=daytime[i];

            (* clear the rest of the array *)
            for i := nam.length +1 to namelength
            do nam.letters[i] := ' ';

            line := libline
         end;

      (* insert date in the catalog *)
      case catnumber of (* ccc *)
         1: dumpitem(c1, catitem);
         2: dumpitem(c2, catitem);
         3: dumpitem(c3, catitem);
      end;

      (* complete skip of library header line *)
      readln(lib);
      libline:=succ(libline)
end; (* readlibdate *)

(* *******************************************************************)
(* catalog writing procedures*****************************************)

{ apparently we don't need lib or newlib here! TDS 1992 Sep 14
procedure dumptocat(var lib, newlib:text;chr:char);
}
procedure dumptocat(chr:char; var c1,c2,c3: catfile);
(* dump an item to the cat *)
begin (* dumptocat *)
      (* set new catitem name *)
      with catitem do begin
         nam.letters:=aname.letters;
         (* the nam.length was set in procedure getname *)
         letter := chr;
         line := libline-2;
      end;
      (* reason for use of libline-2:
      we are already 2 lines ahead of the first line of the item.
      example:
      ...
      organism             libline-2
      * name               libline-1
      * ...                libline
      ^ is the next character to be read, but the organism
      starts at libline-2.
      *)

      case catnumber of (* ccc *)
         1: dumpitem(c1, catitem);
         2: dumpitem(c2, catitem);
         3: dumpitem(c3, catitem)
      end
end; (* dumptocat *)

(* *******************************************************************)
(* humcat writing procedures******************************************)

procedure shortname(var afile: text; n: name);
(* write the name n without blanks *)
var
   i: integer; (* index to the name *)
begin
   i := 1;
   while n.letters[i] <> ' ' do begin
     write(afile,n.letters[i]);
     i := i + 1
   end;
end;

procedure writehumcat(callingproc:calltype);
(* write out a nice human listing *)
var   fieldsize: integer; (* size to put a name or spaces in *)
   l: integer; (* index to levelsize *)
begin (* writehumcat *)
      writeln(humcat);
      humcatlines := succ(humcatlines);
      (* doing this as a carriage return of the previous line allows
      many things to be put on each line of cat after the call to
      humcat.  note that the last carriage return is done at the end
      of the program. *)

   if (humcatlines >= pagesize) (* paging control *)
   then dopage;

      (* space out to proper indentation *)
      for l := 1 to levelsize*level do write(humcat, ' ');
{
      write(humcat, ' ':levelsize*level);
      write(humcat, ' ':levelsize*level+1);
}
{
      fieldsize := (maxnamelength + 10) - levelsize*level;
}
      fieldsize := 11; (* just fits 'chromosome ' *)
      case callingproc of (* note: each part in quotes is 17 characters *)

      organism: begin
           write(humcat, 'organism ');
           writename(humcat, current.organism.nam);
           write(humcat,     ' ':(namespace - current.organism.nam.length));
           end;

      chromosome: begin
           write(humcat, 'chromosome ');
           writename(humcat, current.chromosome.nam);
           write(humcat,     ' ':(namespace - current.chromosome.nam.length));
           end;

      marker: begin
           write(humcat, 'marker ');
           writename(humcat, current.marker.nam);
           write(humcat,     ' ':(namespace - current.marker.nam.length));
           end;

      transcript: begin
           write(humcat, 'transcript ');
           writename(humcat, current.transcript.nam);
           write(humcat,     ' ':(namespace - current.transcript.nam.length));
           end;

      gene: begin
           write(humcat, 'gene ');
           writename(humcat, current.gene.nam);
           write(humcat,     ' ':(namespace - current.gene.nam.length));
           end;

      piece: begin
           write(humcat, 'piece ');
           writename(humcat, current.piece.nam);
           write(humcat,     ' ':(namespace - current.piece.nam.length));
           end;

      recognitionclass: begin
           write(humcat, 'recognition-class ');
           writename(humcat, current.recognition.nam);
           write(humcat,     ' ':(namespace - current.recognition.nam.length));
           end;

      enzyme: begin
           write(humcat, 'enzyme ');
           writename(humcat, current.enzyme.nam);
           write(humcat,     ' ':(namespace - current.enzyme.nam.length));
           end;

{
         organism:         write(humcat, 'organism         ',
                                  current.organism.nam.letters:fieldsize);
         chromosome:       write(humcat, 'chromosome       ',
                                  current.chromosome.nam.letters:fieldsize);
         marker:           write(humcat, 'marker           ',
                                  current.marker.nam.letters:fieldsize);
         transcript:       write(humcat, 'transcript       ',
                                  current.transcript.nam.letters:fieldsize);
         gene:             write(humcat, 'gene             ',
                                  current.gene.nam.letters:fieldsize);
         piece:            write(humcat, 'piece            ',
                                  current.piece.nam.letters:fieldsize);
         recognitionclass: write(humcat, 'recognition-class',
                                  current.recognition.nam.letters:fieldsize);
         enzyme:           write(humcat, 'enzyme           ',
                                  current.enzyme.nam.letters:fieldsize);
}

      end;
(* old: we are now 28 + namelength characters over... *)

      (* do the instructions *)
      if docomments then writeln(catin);
      case callingproc of
         organism: begin
            write(catin, 'organism ');
            writename(catin,current.organism.nam);
         end;
         chromosome: begin
            write(catin, 'chromosome ');
            writename(catin,current.chromosome.nam);
         end;
         marker: begin
            write(catin, 'marker ');
            writename(catin,current.marker.nam);
         end;
         transcript: begin
            write(catin, 'transcript ');
            writename(catin,current.transcript.nam);
         end;
         gene: begin
            write(catin, 'gene ');
            writename(catin,current.gene.nam);
         end;
         piece: begin
            write(catin, 'piece ');
            writename(catin,current.piece.nam);
         end;
         recognitionclass: begin
            write(catin, 'recognition-class');
            writename(catin,current.recognition.nam);
         end;
         enzyme: begin
            write(catin, 'enzyme ');
            writename(catin,current.enzyme.nam);
         end;
      end;
      writeln(catin, ';');
(*;if debugging then write(humcat,'=') *)
end; (* writehumcat *)
(* *******************************************************************)
(* list-handling procedures*******************************************)

procedure allocate(var last:listptr);
(* obtain a listptr *)
begin (* allocate *)
      if freelistptr <> nil
      then begin
         last := freelistptr;
         freelistptr := freelistptr^.nextonlist
      end
      else new(last);

      last^.nam := none;
      last^.nextonlist := nil
end; (* allocate *)

procedure return(var node:listptr);
(* return a listptr to the free pool *)
var   lptr: listptr; (* temporary ptr for holding the lists *)
begin (* return *)
      if node <> nil then begin
         lptr := node;
         node := node^.nextonlist;
         lptr^.nextonlist := freelistptr;
         freelistptr := lptr
      end
end; (* return *)

(* *********************************************************************)
function equalname(var a,b: name): boolean;
(* compare the two names.
2004 July 8: Code stolen from module equalstring in prgmod.p
*)
var
   equal: boolean; (* true if the two are equal *)
   index: integer; (* counter for the names *)
begin

   if a.length = b.length
   then begin
      index := 1;
      repeat
         equal := (a.letters[index] = b.letters[index]);
         index := succ(index)
      until (not equal) or (index > a.length);
      equalname := equal
   end
   else equalname := false
end;

procedure pushname(var the:listptr;var latest: listptr);
(* put a name on a list *)
begin
   if the=nil
      then (* no names on here *)
         begin
            allocate(the);
            the^.nam := aname;
            the^.nextonlist := nil;
            latest := the
         end
      else (* check for duplicate and go deeper *)
         begin
            if equalname(the^.nam, aname)
               then
                  unique := false
               else
                  pushname(the^.nextonlist, latest)
         end
end;

procedure popnames(var the:listptr);
(* clear a list completely *)
begin (* present node *)
   if the <> nil
      then
         begin
            while the^.nextonlist <> nil
               do
               popnames(the^.nextonlist);
            return(the) (* present node *)
         end
end;
(* *******************************************************************)
(* duplicate name-handling procedures*********************************)

procedure up(position: integer);
(* procedure up increments a 'number' in character format and calls
      a carry routine if needed. *)
var
      endofnum: integer;(* the right end of a generated number in the
                           line buffer, in case shifting is needed to
                                                fit the number *)
   procedure addcarry(position: integer);
      (* procedure addcarry sets a nine to a zero and propagates a carry
            if we get back to the top of the number and still need a carry
            addcarry will call a subroutine, shift, to shift the number
            in the line buffer. to propagate carries through the number,
            addcarry calls itself with successively lower numbers as
            subscripts for the line buffer. *)

      procedure shift(endofnum: integer);
      (* procedure carry shifts a number right starting with the special
            character and going to the end of the number. it puts a '1'
            in the new location and updates the name and line lengths *)
      var
            position: integer;        (* current position on line *)
      begin
         for position := endofnum downto (uniquebeg + 1)
            do line[position+1] := line[position];
         line[uniquebeg + 1] := '1';
         (* increment name and line lengths *)
         catitem.nam.length := succ(catitem.nam.length);
         length(* of line*) :=succ(length)
      end; (* of procedure shift *)

   begin
      line[position] := '0';
      position := pred(position);
      if line[position] = specialchar
         then shift(endofnum)
         else case line[position] of
            '0', '1', '2',
            '3', '4', '5',
            '6', '7', '8': line[position] := succ(line[position]);
                '9'     : addcarry(position)
         end (* of case *)
   end;(* of procedure addcarry *)

begin
   while (line[position] = ' ')and(position>uniquebeg)
      do position := pred(position);
      (* we are now at the end of either our number or our name *)
   case line[position] of
      ' ': begin
               (* adjust name length *)
               catitem.nam.length := catitem.nam.length + 2;
               length(* of line *) := length + 2;
               line[position] := specialchar ;
               position := succ(position);
               line[position] :=firstnumber (* a global constant *)
            end;
      '0', '1', '2',
      '3', '4', '5',
      '6', '7', '8': line[position] := succ(line[position]);
          '9'    : begin
                        endofnum := position;(* right end *)
                        addcarry(endofnum)
                     end
   end (* of case *)
end;(* of procedure up *)

procedure changename(var the: listptr; var latest: listptr);
(* procedure changename calls one subroutine, up, if a name
   can be changed. if it cannot, a message is printed out and
   the program is aborted. if it can, it is changed and procedure
   pushname is called to insert the new name on the list. if
   it is still non-unique, the main program will call changename
   until it aborts or puts the name on the list.
   this is required by libdef catalogue definition p. 3.1 2b *)
begin
   toolong := false;
   if (line[namelength+2] in [' ', '0'..'9'])
      then up(namelength + 2)
      else toolong := true;
   getname;
   if catitem.nam.length > namelength
      then toolong := true
      else newnamelength := catitem.nam.length;
   if toolong
      then
         begin
{zzz}
            writeln(output,'New generated name is too long.');
            writeln(output,'Change namelength constant.');
            writeln(output,'namelength = ', namelength:1);
            writeln(output,'namelength = ', namelength:1);
            halt
         end;
   unique := true;
   pushname(the, latest)
end;

procedure duplicate(callingproc: calltype; var root: listptr);
(* duplicate writes out a message saying a duplicate name was found then
   dumps the lists of names. it then makes the name unique and writes
   a message giving the old and new names.*)
begin (* duplicate *)
   write(output, ' duplicate ');
   case callingproc of
      organism:         write(output, 'organism');
      recognitionclass: write(output, 'recognition-class');
      enzyme:           write(output, 'enzyme');
      chromosome:       write(output, 'chromosome');
      marker:           write(output, 'marker');
      transcript:       write(output, 'transcript');
      gene:             write(output, 'gene');
      piece:            write(output, 'piece');
   end;
   writeln(output, ' name found.');

   dumplists;

   write(output, ' old name was ');
   writename(output,aname);
   writeln(output);
   uniquebeg := 2 + catitem.nam.length + 1;
   (* star, space, then to the other side of the name *)
   repeat changename(root, latest)
   until unique;
   write(output, ' new name is  ');
   writename(output,latest^.nam);
   writeln(output);
end; (* duplicate *)

procedure changeto (newname: name);
(* changes a name in the current line to an already known new name. *)
var
     i: integer;
     difference: integer;    (* difference in length between old
                                   new names *)
begin (* changeto *)
   getname;
   difference := newnamelength - catitem.nam.length;
   length := length + difference; (* change line length to reflect new name *)
   (* note: we know at this time that the new name
          is at least as long as the old name *)
   for i := 0 to (length-2-catitem.nam.length) do
      line[length-i] := line[length-i-difference];
   for i := 1 to newnamelength do
      line[2+i] := newname.letters[i];
(* if debugging then write(output, 'new name:');
if debugging then for i := 1 to newnamelength do write(output, newname[i]);
if debugging then writeln(output);
if debugging then write(output, 'latest name:');
if debugging then for i := 1 to newnamelength do write(output, latest^.name[i]);
if debugging then writeln(output);
if debugging then writeln(output, 'newnamelength: ', newnamelength); *)
   getname
end; (* changeto *)

(* *******************************************************************)
(* mid-level procedures **********************************************)

procedure writedirect(var f: text; d: direction);
(* write the direction d to the file f *)
begin (* writedirect *)
      case d of
         minus: write(f, '- ':dfield);
         plus:  write(f, '+ ':dfield)
      end
end; (* writedirect *)

procedure writeconfig(var f: text; c: configuration);
(* write the configuration c to the file f *)
begin (* writeconfig *)
      case c of
         linear:   write(f, '   linear':cfield);
         circular: write(f, ' circular':cfield)
      end
end; (* writeconfig *)

procedure writepieceinfo(var f: text; p: pieceinfo);
(* write the piece information to f *)
begin (* writepieceinfo *)
      with p do begin
         writeconfig(f, config);
         writedirect(f, direct);
         write(f, ' ',beginning: nfield);
         write(f, ' ',ending:    nfield)
      end
end; (* writepieceinfo *)

procedure checkmap(geneticlocation: real);
(* check that the location is in the map.  this is required by libdef
catalogue definition p. 3.1, 2c *)
begin (* checkmap *)
      if (geneticlocation < mapbeg) or (mapend < geneticlocation)
      then error(maplocation)
end; (* checkmap *)

procedure skipheader(var lib, newlib:text);
(* skip the rest of the header-nothing useful here *)
begin (* skipheader *)
      checkstar(true); (* check short name *)
      needlibline(lib, newlib, length); (* skip full name *)
      checkstar(false); (* check full name *)
      (* skip the note, if one exists *)
      if lib^='n' then begin
         needlibline(lib, newlib, length);
         repeat
            needlibline(lib, newlib, length);
            if line[1] <> '*'
            then begin
               if line [1] <> 'n' then begin
                  erroratline;
                  writeln(humcat, ' missing asterisk (*) in note');
                  writeln(catin, ' missing asterisk (*) in note');
                  humcatlines := succ(humcatlines);
                  fatal := succ(fatal);
               end
            end
            else if length > 1 then if line[2] <> ' ' then begin
               erroratline;
               writeln(humcat, ' missing blank in note');
               writeln(catin, ' missing blank in note');
               humcatlines := succ(humcatlines);
               fatal := succ(fatal);
            end
         until line[1]='n'
      end
end; (* skipheader *)

procedure piecekey(var lib, newlib: text; var coo, pie: pieceinfo);
(* parses a piece key information *)
var
      badtoken: boolean;   (* true iff next token is not a real number *)
      geneticmap: real;     (* used to check genetic map beginning *)
begin (* piecekey *)
   getreal(lib, newlib, geneticmap, badtoken);
   if badtoken then error(genebeginning);

   getconfig(lib, newlib, coo.config, badtoken);
   if badtoken then error(cooconfigurationbad);

   getdirect(lib, newlib, coo.direct, badtoken);
   if badtoken then error(coordirectionbad);

   getinteger(lib, newlib, coo.beginning, badtoken);
   if badtoken then error(coordbeginningbad);

   getinteger(lib, newlib, coo.ending, badtoken);
   if badtoken then error(coordendingbad);

   getconfig(lib, newlib, pie.config, badtoken);
   if badtoken then error(pieconfigurationbad);

   getdirect(lib, newlib, pie.direct, badtoken);
   if badtoken then error(piedirectionbad);

   getinteger(lib, newlib, pie.beginning, badtoken);
   if badtoken then error(piebeginningbad);

   getinteger(lib, newlib, pie.ending, badtoken);
   if badtoken then error(pieendingbad);

      (* write the piece info to humcat *)
      write(humcat,geneticmap:nfield:2);
      write(humcat,' |');
      writepieceinfo(humcat, coo);
      write(humcat,' |');
      writepieceinfo(humcat, pie);
      checkmap(geneticmap);

      (* write the piece info to catin *)
      if docomments then begin
         write(catin, '(* coordinates: ');
         write(catin,geneticmap:nfield:1);
         writeln(catin,' genetic map beginning');
         writepieceinfo(catin, coo);
         writeln(catin,': coordinate config, dir, beg, end');
         writepieceinfo(catin, pie);
         writeln(catin,': piece config, dir, beg, end *)');
      end;

      checkmap(geneticmap)

end; (* piecekey *)

procedure writehumpieceinfo;
(* write the header info for pieces *)
begin (* writehumpieceinfo *)
   write(humcat, '|   config':cfield);
   write(humcat, 'dir':dfield);
   write(humcat, 'begin':nfield);
   write(humcat, 'end':nfield);
end; (* writehumpieceinfo *)

procedure piecehumhead;
(*write the names of the information about each piece *)
procedure alignit;
begin
   write(humcat,{'      ',}
                '       ',
                ' ':(levelsize+namespace));
end;
begin
   alignit;
{
   write(humcat, 'genetic', ' ':(nfield-7));
}
   write(humcat, 'genetic  ');
   write(humcat, '| coordinate',' ':(pfield-10));
   write(humcat, '| piece'); (* was ... or reference *)
   writeln(humcat);
   humcatlines := succ(humcatlines);

   alignit;
   write(humcat, 'map      ');
   writehumpieceinfo;
   write(humcat,' ');
   writehumpieceinfo;
   write(humcat,'length':bfield);
{
this is done in writehumcat
   writeln(humcat);
   humcatlines := succ(humcatlines);
   humcatlines := humcatlines + 1
}
end;

procedure mapbegend(var lib, newlib:text);
(* check the genetic map beginning and ending coordinates *)
var
   badtoken: boolean; (* true iff next token is not proper *)
begin (* mapbegend *)
   getreal(lib, newlib, mapbeg, badtoken);
   if badtoken then error(genebeginning);

   getreal(lib, newlib, mapend, badtoken);
   if badtoken then error(geneending);

{
   write(humcat,' ':todatafield, mapbeg:nfield:2, ' ', mapend:nfield:2,
      ' (genetic map range)');
}
   writeln(humcat,' ', mapbeg:nfield:2, ' ', mapend:nfield:2,
      ' (genetic map range)');
   if docomments then begin
      writeln(catin,'(* genetic map range is: ',
         mapbeg:nfield:2, ' to ', mapend:nfield:2, ' *)');
   end;

   piecehumhead;
end; (* mapbegend *)

procedure piereference(var lib, newlib:text);
var
      geneticmap: real; (* the genetic map location *)
      badtoken: boolean; (* true iff next token is not proper *)
begin (* piereference *)
   needline(lib, {newlib,} length); (* note: must not write out yet:
                                   the name could change *)
   getname;
   if equalname(piecename, none)     (* no other references made yet *)
      then
         begin
            changed := false;
            piecename := aname;
            unique := true;
            pushname(first.piece.nextonlist, latest);
            if not unique
              then
                 begin
                    duplicate(piece, first.piece.nextonlist);
                    newpiecename := latest^.nam;
                    changed := true
                 end
        end
      else if not equalname(piecename, aname)
           then error(nolastpiece)
           else if changed then changeto(newpiecename);
   dumpline(newlib, length);

   getreal(lib, newlib, geneticmap, badtoken);
   if badtoken
   then error(mapbeginning)
   else checkmap(geneticmap);

   getdirect(lib, newlib, pieceref.nodedir, badtoken);
   if badtoken then error(refdirectionbad);

   getinteger(lib, newlib, pieceref.nodebeg, badtoken);
   if badtoken then error(refbeginningbad);

   getinteger(lib, newlib, pieceref.nodeend, badtoken);
   if badtoken then error(refendingbad);

      (* write reference info to humcat *)
      with pieceref do begin
{
         write(humcat,' ':todatafield);
}
         write(humcat,' ');
         write(humcat,geneticmap:nfield:2);
         (* skip coordinate and configuration: *)
         write(humcat,' ':(cfield + pfield));
         writedirect(humcat,nodedir);
         write(humcat,nodebeg:nfield);
         write(humcat,nodeend:nfield);
      end;

      (* write reference info to catin *)
      with pieceref do begin
         write(catin,'(* ');
         write(catin,geneticmap:nfield:2);
         (* skip coordinate and configuration: *)
         writedirect(catin,nodedir);
         write(catin,nodebeg:nfield);
         write(catin,nodeend:nfield);
         writeln(catin,' *)');
      end;

end; (* piereference *)

procedure dosite(var lib, newlib:text);
(* skip sites for now *)
begin
   repeat
      needlibline(lib, newlib, length)
   until line[1] = 's';
   needlibline(lib, newlib, length) (* line after right site bracket *)
end;

procedure dodna(var lib, newlib:text);
(* check the DNA of a piece, as required by
   libdef catalogue definition p. 3.1 2k *)
var i: integer; (* the current character on a line *)
begin (* dodna *)
   needlibline(lib, newlib, length); (* move past the "DNA" *)
   basecount := 0;
   while line[1] = '*' do begin  (* for each line of DNA, *)
      checkstar(true);
      i := 3; (* the first base is the third character on the line *)
      while i<= length do begin  (* count bases on the line *)
         if line[i] in ['a', 'c', 't', 'g']
         then basecount := basecount+1
         else if line[i] <> ' ' then begin
            erroratline;
            writeln(humcat, ' DNA sequence contains "',
                           line[i], '" which is not allowed',
                           ' in a delila library.');

            write(humcat, ' in piece ');
            writename(humcat, latest^.nam);
            writeln(humcat);

            writeln(humcat);
            writeln(catin, ' DNA sequence contains "',
                           line[i], '" which is not allowed',
                           ' in a delila library.');

            write(catin, ' in piece ');
            writename(catin, latest^.nam);
            writeln(catin);

            writeln(catin);
            humcatlines := humcatlines + 3;
            fatal := succ(fatal)
         end;
         i := i+1
      end;
      needlibline(lib, newlib, length)
   end;
   if line[1] <> 'd'
      then
         strange(dna);

   (* print the name of the object containing the dna *)
   if not equalname(current.piece.nam, none)
   then begin
         write(output, ' ');
         writename(output,current.piece.nam);
         writeln(output, ' ', basecount:6, ' bp')
   end
   else if not equalname(current.marker.nam, none)
   then begin
         write(output, ' ');
         writename(output,current.marker.nam);
         writeln(output, ' ', basecount:6, ' bp (a marker)')
   end
   else begin
      writeln(output, 'program error in dodna');
      halt
   end;

   write(humcat, ' ', basecount:6, ' bp'); (* this defines constant bfield *)
   if docomments then begin
      writeln(catin, '(* total length: ', basecount:1, ' bp *)');
   end;
   if fromtoinst
   then writeln(catin, 'get from ',pie.beginning:1,' to same +',(basecount-1):1,';')
   else writeln(catin, 'get all piece;'); (* original *)
{zq}
         (* get from 50 -0 to same +[piecelength-1]; *)
   needlibline(lib, newlib, length)    (* next line after right dna
                                                bracket *)
end; (* dodna *)

(* *********************************************************************)
(* high-level procedures**********************************************)

procedure domarker(var lib, newlib:text; var c1,c2,c3: catfile);
begin  (* do a marker *)
   level := 2;
   needline(lib, {newlib,} length);   (* get to line with marker name *)
   getname;
   unique := true;
   pushname(first.marker.nextonlist, latest);
   if (not unique)  (* duplicate names *)
      then
         duplicate(marker, first.marker.nextonlist);
   current.marker.nam := latest^.nam;
   dumptocat({lib, newlib,} 'm', c1,c2,c3);    (* dump a line to the cat *)
   dumpline(newlib, length);
   writehumcat(marker);
   skipheader(lib, newlib);
   pieceref.nodetype := markref;
   pieceref.nodename := current.marker.nam;
   piereference(lib, newlib);
   needlibline(lib, newlib, length);
   checkstar(true);
   needlibline(lib, newlib, length); (* state line - skip here *)
   checkstar(true);
   needlibline(lib, newlib, length); (* phenotype line skipped *)
   if line[1]='d'
      then
         dodna(lib, newlib)
      else   (* must be dna here *)
         strange(dna);
   if line[1] <> 'm'   (* after which we must be done *)
      then
         strange(marker);
   needlibline(lib, newlib, length);
   current.marker.nam := none   (* clear current marker name *)
end;

procedure dogene(var lib, newlib:text; var c1,c2,c3: catfile);
begin  (* do a gene *)
   level := 2;  (* level is set for the catalog listing *)
   needline(lib, {newlib,} length);
   getname;
   unique := true;
   pushname(first.gene.nextonlist, latest);
   if (not unique)
      then
         duplicate(gene, first.gene.nextonlist);
   dumpline(newlib, length);
   dumptocat({lib, newlib,} 'g', c1,c2,c3);
   current.gene.nam := latest^.nam;
   writehumcat(gene);
(*   write(humcat,' ':bfield);  field for basepairs is empty for now *)
   skipheader(lib, newlib);
   pieceref.nodetype := generef;
   pieceref.nodename := current.gene.nam;
   piereference(lib, newlib);
   needlibline(lib, newlib, length);
   if line[1] <>'g'
      then (* should be done with the gene *)
         strange(gene);
   needlibline(lib, newlib, length);
   current.gene.nam := none  (* clear current gene name *)
end;

procedure dotranscript(var lib, newlib:text; var c1,c2,c3: catfile);
begin   (* do a transcript *)
   level := 2;
   needline(lib, {newlib,} length);
   getname;
   unique := true;
   pushname(first.transcript.nextonlist, latest);
   if (not unique)
      then
         duplicate(transcript, first.transcript.nextonlist);
   dumpline(newlib, length);
   dumptocat({lib, newlib,} 't', c1,c2,c3);
   current.transcript.nam := latest^.nam;
   writehumcat(transcript);
(*   write(humcat,' ':bfield);  field for basepairs is empty for now *)
   skipheader(lib, newlib);
   pieceref.nodetype := transref;
   pieceref.nodename := current.transcript.nam;
   piereference(lib, newlib);
   needlibline(lib, newlib, length);
   if line[1] <>'t'
      then  (* should be done with transcript *)
         strange(transcript);
   needlibline(lib, newlib, length); (* get to next line past
                                             transcript line *)
   current.transcript.nam := none
end;

(* begin module checkcoordinates *)
function checkcoordinates(piedir: direction;
                          piebeg, pieend,
                          coobeg, cooend: integer): integer;
(* calculate the length of a piece with the input piecekey values.
the function was derived from the standard piecelength and
pietoint functions in delmods. *)
var   length: integer; (* temporary answer *)
begin (* checkcoordinates *)
      case piedir of
         plus:  if pieend >= piebeg
                then length := (pieend - piebeg) + 1
                else length := (pieend - coobeg) + (cooend - piebeg) + 2;
         minus: if pieend <= piebeg
                then length := (piebeg - pieend) + 1
                else length := (cooend - pieend) + (piebeg - coobeg) + 2
      end;
      checkcoordinates := length
end; (* checkcoordinates *)
(* end module checkcoordinates *)

procedure dopiece(var lib, newlib:text; var c1,c2,c3: catfile);
var
      predictedlength: integer; (* the length of sequence predicted
         from the coordinates *)
begin
   level := 2;
   needline(lib, {newlib,} length);
   getname;
   if equalname(piecename, none)
      then
            begin
               (* cautions for pieces without a family - show only
                  when debugging because they are a pain most of the time. *)
               if debugging then error(noreference);
               unique := true;
               pushname(first.piece.nextonlist, latest);
               if (not unique)
                  then
                     begin
                        duplicate(piece, first.piece.nextonlist);
                        changed := true;
                        newpiecename := latest^.nam
                     end
            end (* if piecename = none *)
      else
          if not equalname(piecename, aname)
          then error(wrongreference)
          else if changed then changeto(newpiecename);
   dumptocat({lib, newlib,} 'p', c1,c2,c3);
   if not changed
      then current.piece.nam := aname
      else current.piece.nam := newpiecename;
   piecefound := true;
   piecename := none; (* i.e., no current reference open *)
   dumpline(newlib, length);

   writehumcat(piece);
   skipheader(lib, newlib);
   piecekey(lib, newlib, coo, pie);  (* parse the piece key *)
   needlibline(lib, newlib, length);
   if line[1]='d'
      then (* there must be dna here *)
         dodna(lib, newlib)
      else
         strange(dna);

   (* use pie and coo to check the expected length of the piece
      compared to basecount as required by
      libdef catalogue definition p. 3.1 2i *)
   predictedlength := checkcoordinates(pie.direct, pie.beginning, pie.ending,
                                                  coo.beginning, coo.ending);
   if predictedlength <> basecount
   then begin
      erroratline;
      writeln(humcat, ' length of piece predicted from piece',
                     ' coordinates was: ', predictedlength:5);
      writeln(humcat, ' the actual number of bases counted was:',
                       basecount:20);
      writeln(humcat, ' the difference is',
                       (predictedlength-basecount):(60-18));
      write(humcat, ' for piece ');
      writename(humcat,current.piece.nam);
      writeln(humcat);

      writeln(catin, ' length of piece predicted from piece',
                     ' coordinates was: ', predictedlength:5);
      writeln(catin, ' the actual number of bases counted was:',
                       basecount:20);
      writeln(catin, ' the difference is',
                       (predictedlength-basecount):(60-18));
      write(catin, ' for piece ');
      writename(catin,current.piece.nam);
      writeln(catin);


(* this stuff can be used to check the humcat list:
      writeln(humcat, ' coordinate beginning ', coo.beginning:5);
      writeln(humcat, ' coooordinate ending  ', coo.ending:5);
      write(humcat,  ' piece direction          ');
      writedirect(humcat, pie.direct);
      writeln(humcat);
      writeln(humcat, ' piece beginning      ', pie.beginning:5);
      writeln(humcat, ' piece ending         ', pie.ending:5);
*)
      humcatlines := humcatlines + 4;
      fatal := succ(fatal)
   end;

      (* check coordinate order
         as required by libdef catalogue definition p. 3.1 2h *)
      if coo.beginning > coo.ending
      then begin
         erroratline;
         writeln(humcat,' coordinate beginning must be less than',
                        ' or equal to ending');
         writeln( catin,' coordinate beginning must be less than',
                        ' or equal to ending');
         humcatlines := succ(humcatlines);
         fatal := succ(fatal)
      end;

      (* check configuration
         as required by libdef catalogue definition p. 3.1 2j *)
      if coo.config = linear
         then if pie.config <> linear then begin
            erroratline;
            writeln(humcat,' linear coordinates imply linear pieces');
            writeln( catin,' linear coordinates imply linear pieces');
            humcatlines := succ(humcatlines);
            fatal := succ(fatal)
         end;


   if line[1]<>'p'
      then (* and we should now be finished *)
         strange(piece);
   needlibline(lib, newlib, length);
   current.piece.nam := none;  (* clear current piece name *)

{
make it more compact, don't writeln between families:
old:
   (* put blanks between families *)
   writeln(humcat);
   humcatlines:=succ(humcatlines);
}

   (* although the name of the piece of this family may have been
   changed, we do not want to change the names of later pieces: *)
   changed := false
end;

procedure dochromosome(var lib, newlib:text; var c1,c2,c3: catfile);
begin
   level := 1;
   needline(lib, {newlib,} length);
   getname;
   unique := true;
   pushname(first.chromosome.nextonlist, latest);
   if (not unique)
      then
         duplicate(chromosome, first.chromosome.nextonlist);
   dumptocat({lib, newlib,} 'c', c1,c2,c3);
   dumpline(newlib, length);
   current.chromosome.nam := latest^.nam;
   writehumcat(chromosome);
   skipheader(lib, newlib);
   mapbegend(lib, newlib);   (* check map beginning and ending *)
   needlibline(lib, newlib, length);
   while (line[1] in ['m', 't', 'g', 'p']) do
      begin
         if line[1]='m'
            then (* we have a marker next *)
               domarker(lib, newlib, c1,c2,c3)
            else
               if line[1]='t'
                  then  (* we have a transcript *)
                     dotranscript(lib, newlib, c1,c2,c3)
                  else
                     if line[1]='g'
                        then  (* we have a gene *)
                           dogene(lib, newlib, c1,c2,c3)
                        else  (* or we have a piece *)
                           dopiece(lib, newlib, c1,c2,c3)
      end;
   if line[1]<>'c'
      then (* no more of those, so our chromosome
                        must be done *)
         strange(chromosome);

    (* clear the lists of names of markers, transcripts,
       genes, and pieces in this chromosome *)
   popnames(first.marker.nextonlist);
   popnames(first.transcript.nextonlist);
   popnames(first.gene.nextonlist);
   popnames(first.piece.nextonlist);
   needlibline(lib, newlib, length);
   current.chromosome.nam := none
end;

procedure doenzyme(var lib, newlib:text; var c1,c2,c3: catfile);
begin  (* do an enzyme *)
   level := 1;
   needline(lib, {newlib,} length);
   getname;
   unique := true;
   pushname(first.enzyme.nextonlist, latest);
   if (not unique)
      then
         duplicate(enzyme, first.transcript.nextonlist);
   dumptocat({lib, newlib,} 'e', c1,c2,c3);
   dumpline(newlib, length);
   current.enzyme.nam := latest^.nam;
   writehumcat(enzyme);
   skipheader(lib, newlib);
   needlibline(lib, newlib, length);
   needlibline(lib, newlib, length);
   while line[1]='s'   (* while we have sites *)
      do
      dosite(lib, newlib);
   if line[1] <>'e'
      then  (* we should now be done *)
         strange(enzyme);
   needlibline(lib, newlib, length);
   current.enzyme.nam := none (* clear enzyme name *)
end;

procedure doorganism(var lib, newlib:text; var c1,c2,c3: catfile);
var   i: integer; (* index for writing map units *)
begin  (* do an organism *)
   level := 0;
   needline(lib, {newlib,} length);  (* get to the line with the name *)
   getname;
   unique := true;
   pushname(first.organism.nextonlist, latest);
   if (not unique)
      then
         duplicate(organism, first.organism.nextonlist);
   dumptocat({lib, newlib,} 'o', c1,c2,c3);
   dumpline(newlib, length);
   current.organism.nam := latest^.nam;
   writehumcat(organism);
   skipheader(lib, newlib);
   needlibline(lib, newlib, length);
   checkstar(true); (* genetic map units *)

   (* write map units to humcat *)
   write(humcat,' ');
   for i := 3 to length do write(humcat,line[i]);
   write(humcat,' (genetic map units)');

   if docomments then begin
      write(catin,'(* genetic map units are: ');
      for i := 3 to length do write(catin,line[i]);
      writeln(catin,' *)');
   end;

   needlibline(lib, newlib, length);
   while line[1]='c' do  (* while we have another chromosome, do it *)
      dochromosome(lib, newlib, c1,c2,c3);
   if line[1] <>'o'
      then  (* we should then have been done *)
         strange(organism);
   popnames(first.chromosome.nextonlist);
   current.organism.nam := none
end;

procedure dorecognition(var lib, newlib:text; var c1,c2,c3: catfile);
begin
   level := 0;
   needline(lib, {newlib,} length);
   getname;
   unique := true;
   pushname(first.recognition.nextonlist, latest);
   if (not unique)
      then
         duplicate(recognitionclass, first.recognition.nextonlist);
   dumptocat({lib, newlib,} 'r', c1,c2,c3);
   dumpline(newlib, length);
   current.recognition.nam := latest^.nam;
   writehumcat(recognitionclass);
   skipheader(lib, newlib);
   needlibline(lib, newlib, length);
   checkstar(true);
   needlibline(lib, newlib, length);
   while line[1] ='e' do (* do enzymes until done *)
      doenzyme(lib, newlib, c1,c2,c3);
   if line[1]<>'r'
      then (* should be done with this class now *)
         strange(recognitionclass);
   popnames(first.enzyme.nextonlist);  (* clear the list of enzyme names
                                           for this recognition-class *)
   current.recognition.nam := none   (* clear the recognition-class
                                                         names *)
end;

procedure dolibrary(var lib, newlib: text; var c1,c2,c3: catfile);
(* do a library *)
begin (* dolibrary *)
      reset(lib);
      rewrite(newlib);
      libdone := false; (* becomes true if we are at the end of the library *)
      libline := 1; (* set the libline to one for this file *)

      (*  put the new date in the catalog and the new library *)
      if not eof(lib) then readlibdate(lib, newlib,c1,c2,c3);

      while not eof(lib) do begin
         readline(lib, length);
         dumpline(newlib, length);
         if not libdone (* until we hit the end *)
            then if line[1]='o' (* it may be an organism *)
                 then doorganism(lib, newlib, c1,c2,c3)
                 else if line[1]='r' (* or a recognition *)
                      then dorecognition(lib, newlib, c1,c2,c3)
                      else strange(library) (* or we have neither *)
      end;
      libnumber := succ(libnumber);  (* go to the next library *)
      catnumber := succ(catnumber); (* one cat per lib *)
end; (* dolibrary *)

procedure themain(var catalp: text;
              var l1: text; var c1: catfile; var newl1: text;
              var l2: text; var c2: catfile; var newl2: text;
              var l3: text; var c3: catfile; var newl3: text;
              var humcat, catin: text;
              var fout: text); (* lll ccc *)
(* the main procedure of the program *)
begin (* catal *)
   write(fout, ' catal ', version:4:2, ' ');
   (* obtain date and time *)
   getdatetime(daytime);
   writedatetime(fout, daytime);
   writeln(fout);

   maxnamelength := 0;

   (* Check that there is at least one library. *)
   reset(l1);
   reset(l2);
   reset(l3);
   if (not eof(l1)) or
      (not eof(l2)) or
      (not eof(l3))
      then
         begin
            initializecatalogs(catalp, c1,c2,c3);

            (* lll *)
            dolibrary(l1, newl1, c1,c2,c3);
            dolibrary(l2, newl2, c1,c2,c3);
            dolibrary(l3, newl3, c1,c2,c3);

            (* destroy new libraries and catalogues if there was
               any problem *)
            if fatal <> 0
            then begin (* lll ccc *) rewrite(newl1);
               rewrite(newl2);
               rewrite(newl3);
               rewrite(c1);
               rewrite(c2);
               rewrite(c3);
               writeln(fout, ' ', fatal:1, ' fatal error(s):',
                              ' new libraries and catalogues destroyed');
               writeln(humcat, ' ', fatal:1, ' fatal error(s):',
                              ' new libraries and catalogues destroyed');
               writeln(catin, ' ', fatal:1, ' fatal error(s):',
                              ' new libraries and catalogues destroyed');
               writeln(fout, ' see humcat.')
            end
            (* close any currently open lines in humcat, see writehumcat. *)
            else writeln(humcat);
         end
      else docathelp(fout);
end;

begin
   themain(catalp,
           l1, cat1, lib1,
           l2, cat2, lib2,
           l3, cat3, lib3,
           humcat, catin,
              output); (* lll ccc *)
1: end. (* catal *)
