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. *) (* *********************************************************************) label 1; (* label used for the end of the program *) (* *********************************************************************) const (* begin module version *) version = 9.54; (* of catal.p 2004 Jul 8 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: a parameter to control the program. 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. 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 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 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 = 100; (* maximum key name length *) namespace = 15; (* maximum length for printing name on humcat *) linelength = 120; (* maximum line readable in the library *) 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.08; (@ of gpctime.p 2004 Jan 21 *) (* *********************************************************************) type (* begin module datetime.type *) (* array for dates *) datetimearray = packed array[1..datetimearraylength] of char; (* end module datetime.type version = 1.08; (@ of gpctime.p 2004 Jan 21 *) 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; 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. *) 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 *) 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.08; (@ of gpctime.p 2004 Jan 21 *) (* *********************************************************************) (* *********************************************************************) 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 (http://www.lecb.ncifcrf.gov/~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.08; (@ of gpctime.p 2004 Jan 21 *) (* begin module readdatetime *) procedure readdatetime (var thefile: text; var adatetime: datetimearray); (* read the date and time from the file *) 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,' old datetime (only 2 year digits) read: ', adatetime:datetimearraylength); end; end; (* end module readdatetime version = 1.08; (@ of gpctime.p 2004 Jan 21 *) (* 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.08; (@ of gpctime.p 2004 Jan 21 *) (* begin module timeseed *) 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)); } case c of ' ': begin writeln(output,'timeseed: error in datetime'); halt; end; '0': n := 0; '1': n := 1; '2': n := 2; '3': n := 3; '4': n := 4; '5': n := 5; '6': n := 6; '7': n := 7; '8': n := 8; '9': n := 9 end; (*writeln(output,'timeseed number is [',n:1,']'); (@ debug *) seed := seed + power*n end; (* addtoseed *) procedure makeseed(adatetime: datetimearray; var seed: real); (* convert adatetime to a real number in seed, reversed order *) 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[1]); addtoseed(seed, power, adatetime[2]); 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.08; (@ of gpctime.p 2004 Jan 21 *) (* begin module limitdate *) (* end module limitdate *) (* end module package.datetime version = 1.08; (@ of gpctime.p 2004 Jan 21 *) (* *********************************************************************) (* 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 eof(catalp) then keepdates:=false (* the default *) else begin read(catalp, ch); if ch in ['n', 'b'] then keepdates:=true else keepdates:=false 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); writeln(catin,'(* parent library: '); reportparent(l1); reportparent(l2); reportparent(l3); writeln(catin,' *)'); 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; writeln(catin, ' the line is longer than ', linelength:1, ' characters'); write(catin, ' '); for j:=1 to linelength do write(catin, line[j]); writeln(catin); 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 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 *) {zq} 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 *) 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 writeln(output, ' new generated name too is long.'); writeln(output, ' change namelength constant'); 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 *) 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 *)'); 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)'); writeln(catin,'(* genetic map range is: ', mapbeg:nfield:2, ' to ', mapend:nfield:2, ' *)'); 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 *) writeln(catin, '(* total length: ', basecount:1, ' bp *)'); writeln(catin, 'get all piece;'); 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)'); write(catin,'(* genetic map units are: '); for i := 3 to length do write(catin,line[i]); writeln(catin,' *)'); 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 *)