program keymat(xbook,ybook,hlist,kmlist,keymatp,output);
(* keymat: keyed-symbol  dot matrices of two books
      based on the program matrix by thomas schneider.
      keymat written by patrick roche.

  Thomas D. Schneider, Ph.D.
  National Institutes of Health
  National Cancer Institute
  Gene Regulation and Chromosome Biology Laboratory
  Molecular Information Theory Group
  Frederick, Maryland  21702-1201
  schneidt@mail.nih.gov
  toms@alum.mit.edu (permanent)
  http://alum.mit.edu/www/toms (permanent)

modules from: delman, delmods, prgmods, auxmods
*)

label 1; (* end of program *)

const
(* begin module version *)
   version = 5.40 ; (* of keymat.p 2010 Nov 24
2010 Nov 24, 5.40: upgrade address
2007 Nov 29, 5.39: increase listmax
1994 sep  5, 5.38: functional
1983 dec 20, 1.00: origin before this date
*)
(* end module version *)

(* begin module describe.keymat *)
(*
name
   keymat: keyed-matrices for helices between two books

synopsis
   keymat(xbook: in, ybook: in, hlist: in, kmlist: out,
          keymatp: in, output: out)

files
   xbook: a book from the delila system
   ybook: a book from the delila system.  If you want to look for
      structures in one sequence, then use the program copy to make
      a copy of xbook in ybook.
   hlist: the helix listing for xbook and ybook made by program helix
   kmlist: the matrices listed out.  Sequences from the x book are printed
      vertically, while those from the y book are horizontal.
      Depending on the parameters selected in keymatp, the helices are
      printed as either numbers representing the type of base pair,
      the actual base from the xbook, the actual base from the ybook,
      or a symbol representing the energy of the helix.
      If kmlist is wider than your printer, use the split program.
   keymatp: parameters to control the kmlist
      if keymatp is empty, default values are used.  Otherwise, keymatp
      must contain at least 3 lines.
         line 1: contains a positive integer - the minimum length helix to
            record from hlist into kmlist;
         or a negative real number - the maximum energy of a helix to
         record from hlist to kmlist.
         line 2: contains 2 positive integers greater than or equal to 1.
            These are the x and y scaling factors (respectively) which
            allow you to display large matrices in a small space by
            scaling them down.
         line 3: contains either 'n', 'x', 'y', or 'e',  which define what
             symbols will be printed for the helices in the kmlist.
            'n' - helices will be printed as a set of numbers:
                  1 = g-t bp    2 = a-t bp    3 = g-c bp
            'x' - helices will contain the base from the x-book sequence.
            'y' - helices will contain the base from the y-book sequence.
            'e' - a key symbol for the energy of each helix will be printed.
               The program will produce a table of energies and their
               corresponding key symbols.
               Note: the third parameter request is overridden when either
               scale factor is larger than 1.
         line 4: resolution of energy display.  This defines
                 the resolution of the matrix w/respect to
                 energies.  Used when line 3 is 'e'.
            'n' - numbers ('0' to '9') used for the keys
            'l' - numbers ('a' to 'z') used for the keys
            'a' - numbers ('a' to 'z' and '0' to '9') used (not available)
   output: messages to the user

description
   Keymat produces a keyed-dot matrix for the two books.  The display
   can use numbers and letters to indicate the energy of various helixes.
   One major feature is the ability to compress large regions onto a page
   using scaling factors.
   Only helices of some length (or longer) or of some maximum energy (or less)
   are printed.  The helices are made using program helix.  
   This program was based on the matrix program.

documentation
   J. V. Maizel, Jr. and R. P. Lenk PNAS 78: 7665-7609 (1981)

see also
   helix.p, dotmat.p, matrix.p, split.p

author
   patrick r. roche
bugs
   If maximum energy is strongest helix, the program may object.
   The alphanumeric range does not work.  It bombs with a 'bus error'
   as it reads in the x piece.
*)
(* end module describe.keymat *)

(* more constants: *)
      debug = false;   (* whether or not to turn on debugging statements *)
      headerlines = 7; (* the number of lines in the header of hlist *)
      nodot = ':';     (* the character to print for background,
                          note: it must not blank, so that the user can
                          align the helixes by the numbers. *)
      prime = '''';     (* a single quote for printing *)
      pagelength = 48; (* lines printed of keymat on one page in kmlist *)
      listmax = 1000;   (* maximum number of members in the linked list
                          at any time. this constant can be set so that
                          keymat can be run without bombing on any
                          computer system *)

(* begin module book.const *)
(* constants needed for book manipulations *)

      dnamax = 3000;  (* length of dna arrays *)
      namelength = 20; (* maximum key name length *)
      linelength = 80; (* maximum line readable in book *)

(* end module book.const version = 'delmod 6.51 85 apr 17 tds/gds' *)

type
      helixptr = ^helix;
      helix = record
         x5pos:integer;   (* 5 prime position of helix in the xbook *)
         y3pos:integer;   (* 3 prime position of helix in the ybook *)
         length:integer;  (* length of the helix *)
         symbol:char;     (* the symbol to print for energy if it exists *)
         across: helixptr;(* pointer to a helix *)
      end;

      holderptr = ^holder;
      holder = record
         x: integer;       (* to hold the x5pos *)
         across: helixptr; (* to point to the rows of helixes *)
         down: holderptr;  (* to point down to the next holder *)
      end;

      symbolholder = array[1..37] of char;  (* array for energy symbols *)
      stopholder = array[1..37] of real;    (* array for symbol range stops *)

(* begin module book.type *)
(* types needed for book manipulations *)

      chset = set of 'a'..'z';

      (* types defined in book definition *)

      alpha = packed array[1..namelength] of char; (* this is not alfa *)

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

      lineptr = ^line;
      line = record (* a line of characters *)
         letters: packed array [1..linelength] of char;
         length: 0..linelength;
         next: lineptr
      end;

      direction = (plus, minus, dircomplement, dirhomologous);
      configuration = (linear, circular);
      state = (on, off);


      header = record (* header of key *)
         keynam: name; (* key name of structure *)
         fulnam: lineptr; (* full name of structure *)
         note:   lineptr (* note key *)
      end;


      (* base types *)
      base = (a,c,g,t);
      dnaptr = ^dnastring;
      dnarange = 0..dnamax;
      seq = packed array[1..dnamax] of base;
      dnastring = record
         part: seq;
         length: dnarange;
         next: dnaptr
      end;


      orgkey = record (* organism key *)
         hea: header;
         mapunit: lineptr (* genetic map units *)
      end;

      chrkey = record (* chromosome key *)
         hea: header;
         mapbeg: real; (* number of genetic map beginning *)
         mapend: real (* number of genetic map ending *)
      end;

      pieceptr = ^piece;
      piekey = record (* piece key *)
         hea: header;
         mapbeg: real; (* genetic map beginning *)
         coocon: configuration; (* configruation (circular/linear) *)
         coodir: direction; (* direction (+/-) relative to genetic map *)
         coobeg: integer; (* beginning nucleotide *)
         cooend: integer; (* ending nucleotide *)
         piecon: configuration; (* configruation (circular/linear) *)
         piedir: direction; (* direction (+/-) relative to coordinates *)
         piebeg: integer; (* beginning nucleotide *)
         pieend: integer; (* ending nucleotide *)
      end;


      piece = record
         key: piekey;
         dna: dnaptr
      end;

      reference = record
         pienam : name;  (* name of piece referred to *)
         mapbeg : real;  (* genetic map beginning *)
         refdir : direction;  (* direction relative to coordinates *)
         refbeg : integer;  (* beginning nucleotide *)
         refend : integer;  (* ending nucleotide *)
      end;

      genkey = record  (* gene key *)
         hea : header;
         ref : reference;
      end;

      trakey = record  (* transcript key *)
         hea : header;
         ref : reference;
      end;

      markerptr = ^marker;
      markey = record (* marker key *)
         hea : header;
         ref : reference;
         sta : state;
         phenotype : lineptr;
         next : markerptr;
      end;

      marker = record
         key : markey;
         dna : dnaptr;
      end;

(* end module book.type version = 'delmod 6.51 85 apr 17 tds/gds' *)

var
      xbook,   (* one book *)
      ybook,   (* the other book *)
      hlist,   (* list of helixes *)
      kmlist,  (* the dot matrices *)
      keymatp: (* parameters *)
         text;

      xseq, yseq: pieceptr;      (* the sequences from the books *)
      ylength, xlength: integer; (* length of the sequences *)
      xnumber, ynumber: integer; (* the numbers of the sequences *)

      minlenmaxene: real;        (* a parameter read from keymatp;
                                    the minimum size helix to print
                                    or the maximum energy of the helix *)
      xscale,yscale: integer;    (* the scaling factors *)
      gensymbol: char;           (* the general symbol type to print
                                    n= numbers, x= xbook base,
                                    y= ybook base, e= energy symbol *)
      erange: char;    (* energy symbol-type:
                           n=numbers l=letters a=alphanumerics
                           the choice of energy symbol-type defines
                           the resolution of the matrix w/respect to
                           energies.  used when gensymbol is 'e' *)
      symbols: symbolholder;     (* the array to hold energy symbols *)
      stops: stopholder;         (* the array to hold the energy-range values *)


(* begin module book.var *)
(* ************************************************************************ *)
(* global variables needed for book manipulations *)

      (* free storage: *)
      freeline: lineptr; (* unused lines *)
      freedna: dnaptr; (* unused dnas *)

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

(* ************************************************************************ *)
(* end module book.var version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module package.primitive *)
(* ************************************************************************ *)
(* 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 = 'delmod 6.51 85 apr 17 tds/gds' *)

(* 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 = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module copylines *)
function copylines(var fin, fout: text; n: integer): integer;
(* copy n lines of file fin to file fout.
the actual number of lines copied is returned. *)
var
      index: integer; (* the current line number *)
begin (* copylines *)
      index := 0;
      while (not eof(fin)) and (index < n) do begin
         copyaline(fin, fout);
         index := succ(index)
      end;

      copylines := index
end; (* copylines *)
(* end module copylines version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* ************************************************************************ *)
(* end module package.primitive version = 'delmod 6.51 85 apr 17 tds/gds' *)

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

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

procedure getline(var l: lineptr);
(* obtain a line from the free line list or by making a new one *)
begin
      if freeline<>nil
         then begin
            l:=freeline;
            freeline:=freeline^.next
         end
         else new(l);
      l^.length:=0;
      l^.next:=nil
end;

procedure getdna(var l: dnaptr);
begin
      if freedna<>nil
         then begin
            l:=freedna;
            freedna:=freedna^.next
         end
         else new(l);
      l^.length:=0;
      l^.next:=nil
end;

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

procedure clearline(var l: lineptr);
(* return a line to the free line list *)
var   lptr: lineptr;
begin
      if l<>nil then begin
         lptr:=l;
         l:=l^.next;
         lptr^.next:=freeline;
         freeline:=lptr
      end
end;

procedure cleardna(var l: dnaptr);
var   lptr: dnaptr;
begin
      if l<>nil then begin
         lptr:=l;
         l:=l^.next;
         lptr^.next:=freedna;
         freedna:=lptr
      end
end;

procedure clearheader(var h: header);
(* clear the header h (remove lines to free storage) *)
begin
      with h do begin
         clearline(fulnam);
         while note<>nil do clearline(note)
      end
end;

procedure clearpiece(var p: pieceptr);
(* clear the dna of the piece *)
begin
      while p^.dna<>nil do cleardna(p^.dna);
      clearheader(p^.key.hea)
end;

function chartobase(ch:char):base;
(* convert a character into a base *)
begin
      case ch of
         'a': chartobase:=a;
         'c': chartobase:=c;
         'g': chartobase:=g;
         't': chartobase:=t
      end
end;

function basetochar(ba:base):char;
(* convert a base into a character *)
begin
      case ba of
         a: basetochar:='a';
         c: basetochar:='c';
         g: basetochar:='g';
         t: basetochar:='t';
      end
end;

function complement(ba:base):base;
(* take the complement of ba *)
begin
      case ba of
         a: complement:=t;
         c: complement:=g;
         g: complement:=c;
         t: complement:=a;
      end
end;

function pietoint(p: integer; pie: pieceptr): integer;
(* p is a coordinate on the piece.
   we want to transform p into a number
   from 1 to n: an internal coordinate system for
   easy manipulation of piece coordinates *)
var   i: integer; (* an intermediate value *)
begin
      with pie^.key do begin
         case piedir of
            plus:  if p>=piebeg
                   then i:=p-piebeg+1
                   else i:=(p-coobeg)+(cooend-piebeg)+2;
            minus: if p<=piebeg
                   then i:=piebeg-p+1
                   else i:=(cooend-p)+(piebeg-coobeg)+2
         end;
         pietoint:=i
      end
end;

function inttopie(i: integer; pie: pieceptr):integer;
(* i is in the range 1 to some maximum.  it is an internal coordinate
   system for the program.  we want to do a
   coordinate transformation to obtain
   a value in the range of the piece called pie:
   i=1 corresponds to piebeg and
   i=its maximum corresponds to pieend *)
var   p: integer; (* an intermediate value *)
begin
      with pie^.key do begin
         case piedir of
            plus: begin
               p:=piebeg+(i-1);
               if p>cooend
                  then if coocon=circular
                     then p:=p-(cooend-coobeg+1)
            end;
            minus: begin
               p:=piebeg-(i-1);
               if p<coobeg
                  then if coocon=circular
                     then p:=p+(cooend-coobeg+1)
            end
         end;
         inttopie:=p
      end
end;

function piecelength(pie: pieceptr): integer;
(* return the length of the dna in pie *)
begin
      piecelength:=pietoint(pie^.key.pieend,pie)
end;

(* end module book.basis version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.getto *)
function getto(var thefile: text; ch: chset): char;
(* search the file for a character in the first line which is a
   member of the set ch. *)
var achar: char;
begin
      achar:=' ';
      while (not(achar in ch)) and (not eof(thefile))
         do readln(thefile,achar);
      if (achar in ch) then getto:=achar
                       else getto:=' '
end;
(* end module book.getto version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.skipstar *)
procedure skipstar(var thefile:text);
(* skip start of line (or star = '*'). *)
begin (* skipstar *)
      if thefile^ <> '*' then begin
         writeln(output,' procedure skipstar: bad book');
         writeln(output,' "*" expected as first character on the line, but "',
                        thefile^,'" was found');
         halt
      end;
      get(thefile); (* skip the star *)

      if thefile^ <> ' ' then begin
         writeln(output,' procedure skipstar: bad book');
         writeln(output,' "* " expected on a line but "*',
                        thefile^,'" was found');
         halt
      end;
      get(thefile) (* skip the blank *)
end; (* skipstar *)
(* end module book.skipstar version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brreanum *)
procedure brreanum(var thefile: text; var reanum: real);
(* read a real number from the file *)
begin
      skipstar(thefile);
      readln(thefile,reanum);
end;
(* end module book.brreanum version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brnumber *)
procedure brnumber(var thefile: text; var num: integer);
(* read a number from the file *)
begin
      skipstar(thefile);
      readln(thefile,num)
end;
(* end module book.brnumber version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brname *)
procedure brname(var thefile: text; var nam: name);
(* read a name from the file *)
var   i: integer; (* an index to the name *)
      c: char; (* a character read *)
begin (* brname *)
      skipstar(thefile);
      with nam do begin
         length:=0;
         repeat
            length:=succ(length);
            read(thefile,c);
            letters[length] := c
         until (eoln(thefile)) or
               (length>=namelength) or
               (letters[length]=' ');
         if letters[length]=' ' then length:=length-1;
         if length<namelength
            then for i:=length+1 to namelength do letters[i]:=' '
      end;
      readln(thefile)
end; (* brname *)
(* end module book.brname version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brline *)
procedure brline(var thefile: text; var l: lineptr);
(* read a line from the file *)
var
      i,j: integer;
      acharacter: char;
begin
      skipstar(thefile);
      i:=0;
      while (not eoln(thefile)) do begin
         i:=succ(i);
         read(thefile,acharacter);
         l^.letters[i]:=acharacter
      end;
      if i<l^.length then for j:=i+1 to l^.length do l^.letters[j]:=' ';
      l^.length:=i;
      l^.next:=nil;
      readln(thefile)
end;
(* end module book.brline version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brdirect *)
procedure brdirect(var thefile: text; var direct: direction);
(* read a direction *)
var   ch: char;
begin
      skipstar(thefile);
      readln(thefile,ch);
      if ch='+' then direct:=plus
                else direct:=minus
end;
(* end module book.brdirect version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brconfig *)
procedure brconfig(var thefile: text; var config: configuration);
(* read a configuration *)
var   ch: char;
begin
      skipstar(thefile);
      readln(thefile,ch);
      if ch='l' then config:=linear
                else config:=circular
end;
(* end module book.brconfig version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brnotenumber *)
procedure brnotenumber(var thefile: text; var note: lineptr);
(* book note reading to obtain the number of the object.
the procedure returns the value of the number as a global.
(this is not such a good practice, but we are stuck with it for now.) *)
begin (* brnotenumber *)
      note:=nil;
      numbered := false;
      number := 0; (* force number to zero if there
         is no number at all *)
      (* the next character is n or * depending on whether there are notes *)
      if thefile^ = 'n' then begin
         readln(thefile);
         if thefile^ <> 'n' then begin
            skipstar(thefile);
            if not eoln(thefile) then begin
               if thefile^ = '#' then begin
                  numbered := true;
                  get(thefile); (* move past the number symbol *)
                  read(thefile,number);
               end
            end;
            repeat
               readln(thefile)
            until thefile^ = 'n';
            readln(thefile)
         end
         else readln(thefile)
      end
end; (* brnotenumber *)
(* end module book.brnotenumber version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brnote *)
procedure brnote(var thefile: text; var note: lineptr);
(* read note key *)
var
      newnote: lineptr; (* the new note *)
      previousnote: lineptr; (* the last line of the notes *)
begin (* brnote *)
      note:=nil;
      if thefile^ = 'n' then begin (* enter note *)
         readln(thefile);
         if thefile^ <> 'n' then begin (* abort null note (n/n) *)
            getline(note);
            newnote:=note;
            while thefile^ <> 'n' do begin (* wait until end of note *)
               brline(thefile,newnote);
               previousnote:=newnote;
               (* get next note *)
               getline(newnote^.next);
               newnote:=newnote^.next;
            end;
            (* last note was not used, so: *)
            clearline(newnote);
            previousnote^.next:=nil;
            readln(thefile)
         end
         else readln(thefile)
      end
end; (* brnote *)
(* end module book.brnote version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brheader *)
procedure brheader(var thefile: text; var hea: header);
(* read the header of a key. *)
begin
      with hea do begin
         (* read key name *)
         brname(thefile,keynam);

         (* read full name *)
         getline(fulnam);
         brline(thefile,fulnam);

         (* read note key *)
         if readnumber then brnotenumber(thefile,note)
                       else brnote(thefile,note)
      end
end;
(* end module book.brheader version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brpiekey *)
procedure brpiekey(var thefile: text; var pie: piekey);
(* read piece key *)
begin
      with pie do begin
         brheader(thefile,hea);
         brreanum(thefile,mapbeg);
         brconfig(thefile,coocon);
         brdirect(thefile,coodir);
         brnumber(thefile,coobeg);
         brnumber(thefile,cooend);
         brconfig(thefile,piecon);
         brdirect(thefile,piedir);
         brnumber(thefile,piebeg);
         brnumber(thefile,pieend);
      end
end;
(* end module book.brpiekey version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brdna *)
procedure brdna(var thefile: text; var dna: dnaptr);
(* read in dna from thefile *)
(* note: if the dna were circularized, by linking the last dnastring
to the first, then the cleardna routine could not clear properly,
and would loop forever... there is no reason to do that, since a simple
mod function will allow one to access the circle. *)
var
      ch: char;
      workdna: dnaptr;
begin
      getdna(dna);
      workdna:=dna;
      ch:=getto(thefile,['d']);
      read(thefile,ch); (* skipstar *)
      while (ch = '*') do
      begin
         read(thefile,ch); (* skip blank *)
         repeat
            read(thefile,ch);
            if ch in ['a','c','g','t'] then begin
               if workdna^.length=dnamax then begin
                  getdna(workdna^.next);
                  workdna:=workdna^.next
               end;
               workdna^.length:=succ(workdna^.length);
               workdna^.part[workdna^.length]:=chartobase(ch)
            end
         until eoln(thefile);
         readln(thefile); (* go to next line *)
         read(thefile,ch); (* ch is either '*' or 'd' *)
      end;
      readln(thefile)
end;
(* end module book.brdna version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brpiece *)
procedure brpiece(var thefile: text; var pie: pieceptr);
(* read in a piece *)
begin
      brpiekey(thefile,pie^.key);
      if numbered or (not skipunnum)
         then brdna(thefile,pie^.dna)
end;
(* end module book.brpiece version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.brinit *)
procedure brinit(var book: text);
(* check that the book is ok to read, and
   set up the global variables for br routines *)
begin (* brinit *)
      (* halt if the book is bad (first word is 'halt') or the first
         character is not * *)
      reset(book);
      if not eof(book) then begin
         (* check for the date line *)
         if book^ <> '*' then begin
            if book^ <> 'h'
            then writeln(output, ' this is not the first line of a book:')
            else writeln(output, ' bad book:');
            write(output, ' ');

            while not (eoln(book) or eof(book)) do begin
               write(output, book^);
               get(book)
            end;
            writeln(output);
            halt
         end
      end
      else begin
         writeln(output, ' book is empty');
         halt
      end;

      (* initialize free storage *)
      freeline:=nil;
      freedna:=nil;

      readnumber:=true; (* usually we read in numbers for items *)
      number:=0; (* arbitrary value *)
      numbered:=false; (* the piece has no number (none yet read in) *)
      skipunnum:=false;
end; (* brinit *)
(* end module book.brinit version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* ************************************************************************ *)
(* end module package.brpiece version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.getpiece *)
procedure getpiece(var thefile: text; var pie: pieceptr);
(* move to and read in the next piece in the book *)
var   ch: char;
begin
      ch:=getto(thefile,['p']); (* get to the next p(iece) in the book *)
      if ch<>' ' then begin
         brpiece(thefile,pie);
         ch:=getto(thefile,['p']); (* read past closing p *)
      end
end;
(* end module book.getpiece version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* ************************************************************************ *)
(* end module package.getpiece version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module book.getbase *)
function getbase(position: integer; pie: pieceptr):base;
(* get a base from the nth position (internal coordinates) of the
   piece.  no protection is made against positions outside the piece *)
var
      workdna: dnaptr;
      p: integer; (* the last base of the dna part *)
begin
      workdna:=pie^.dna;
      p:=dnamax;
      while position>p do begin
         p:=p+dnamax;
         workdna:=workdna^.next
      end;
      getbase:=workdna^.part[position-(p-dnamax)]
end;
(* end module book.getbase version = 'delmod 6.51 85 apr 17 tds/gds' *)

(* begin module package.numbar *)
(* ************************************************************************ *)
(* begin module numberdigit *)
function numberdigit(number, logplace:integer): char;
(* return the digit at the place value ('logplace') position of number.
example:
      numberdigit(13625, 3) = 3
      numberdigit(13625, 4) = 1
*)
var
      place: integer; (* the exponent of logplace *)
      count: integer; (* used to make place *)
      absolute: 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:=absolute-((absolute div tenplace)*tenplace);
      if place = 1
         then d:=z
         else d:= z div place;
      case d of
         0: acharacter:='0';
         1: acharacter:='1';
         2: acharacter:='2';
         3: acharacter:='3';
         4: acharacter:='4';
         5: acharacter:='5';
         6: acharacter:='6';
         7: acharacter:='7';
         8: acharacter:='8';
         9: acharacter:='9';
      end
end; (* digit *)
procedure sign;
(* put a negative sign out or a positive sign *)
begin (* sign *)
      if number <0 then acharacter:='-'
                   else acharacter:='+'
end; (* sign *)
begin (* numberdigit *)
      place:=1;
      for count:=1 to logplace do place:=10*place;

      if number=0 then begin
         if place=1 then acharacter:='0'
                    else acharacter:=' '
      end
      else begin
         absolute:=abs(number);
         if absolute < (place div 10)
            then acharacter:=' '
            else if absolute >= place
                    then digit
                    else sign
      end;
      numberdigit:=acharacter
end; (* numberdigit *)
(* end module numberdigit version = 'prgmod 3.96  85 mar 18 tds'; *)

(* begin module numbersize *)
function numbersize(n: integer):integer;
(* calculate amount of space to be reserved for the integer n *)
const ln10 = 2.30259; (* natural log of 10 - for conversion to log base 10 *)
      epsilon = 0.00001; (* a small number to correct log base 10 errors *)
begin (* numbersize *)
      if n = 0
         then numbersize:=1
         else numbersize:=trunc(ln(abs(n))/ln10 + epsilon) + 2;
(* the epsilon assures that we do not lose a place due to
   roundoff.  eg, sometimes log base 10 of 10 would be
   0.9999 instead of 1, and we would not do it right...
   note: this will fail for very large numbers on the order of 1/epsilon. *)
(* the 2 is for the sign and last digit *)
end; (* numbersize *)
(* end module numbersize version = 'prgmod 3.96  85 mar 18 tds'; *)

(* begin module numberbar *)
procedure numberbar(var afile: text; spaces, firstnumber, lastnumber: integer;
                    var linesused: integer);
(* write a bar of numbers to a file, with several spaces before.
   the number of lines used is returned *)
var
      logplace: integer; (* the log of the digit being looked at *)
      spacecount: integer; (* count of spaces *)
      number: integer; (* the current number being written *)
begin
      if abs(firstnumber) > abs(lastnumber)
         then linesused:= numbersize(firstnumber)
         else linesused:= numbersize(lastnumber);

      for logplace:=linesused-1 downto 0 do begin
         for spacecount:=1 to spaces do write(afile,' ');
         for number:=firstnumber to lastnumber
            do write(afile,numberdigit(number,logplace));
         writeln(afile)
      end
end;
(* end module numberbar version = 'prgmod 3.96  85 mar 18 tds'; *)
(* ************************************************************************ *)
(* end module package.numbar version = 'prgmod 3.96  85 mar 18 tds'; *)

(* begin module complines *)
function complines(var a,b: text): boolean;
(* compare one line from each of files a and b starting at the
   current file positions.  both lines are compared up to and including
   the end-of-line mark (i.e., they are both readln-ed).  return true if
   the lines are identical and false if they are not.  ignore trailing
   blanks.  this is done by letting chara or charb assume the
   value of a blank when eoln is true.  when both lines are eoln,
   the next line is inspected.  if one line is at end-of-file and
   the other is not, 'false' is returned.  if both lines are at
   eof, 'true' is returned. *)
var
      chara,charb: char; (*  characters in files a and b *)
      done: boolean; (* stop looking for identity *)
begin
      if eof(a) and eof(b)
         then complines := true
         else if eof(a) or eof(b)
            then complines := false
            else begin (* neither file is eof. *)
               done := false;
               while not done do begin
                  if eoln(a) then chara := ' '
                             else read(a,chara);

                  if eoln(b) then charb := ' '
                             else read(b,charb);

                  if eoln(a) and eoln(b)
                     then begin
                        done := true;
                        complines := true
                     end
                     else if chara <> charb then begin
                        done := true;
                        complines := false
                     end;
               end;
               readln(a);
               readln(b);
            end
end; (* complines *)
(* end module complines version = 'auxmod 1.39 86 dec 12 gds/tds'; *)

(* begin module hlistvsbooks *)
procedure hlistvsbooks (var hlist : text; (* list of helices from helix *)
                     var xbook,ybook : text (* the delila books *) );
(* checks the title line in xbook with the corresponding line in hlist,
   ditto ybook.  if they are not identical, error messages are sent to
   output and the program halts. written by britta singer *)
var   xasx, (* true if xbook input file corresponds to xbook in hlist *)
      yasy, (* true if ybook input file corresponds to ybook in hlist *)
      xasy, (* true if xbook input file corresponds to ybook in hlist *)
      yasx: (* true if ybook input file corresponds to xbook in hlist *)
                     boolean;

procedure gettitleline(var xbook,ybook,hlist : text);
      (* gets to the lines in the xbook, ybook, and hlist input files
         that contain the titles and thus are to be compared *)
begin (* gettitleline *)
      reset(xbook);
      reset(ybook);
      reset(hlist);
      readln(hlist)
end; (* gettitleline *)

procedure findtitle(var hlist : text);
      (* places the cursor at the beginning of the title in hlist *)
var    n : integer; (* counter for skipping characters *)
begin (* findtitle *)
      for n := 1 to 4 do
         get(hlist)
end; (* findtitle *)

begin (* hlistvsbooks *)
      gettitleline(xbook,ybook,hlist);
      findtitle(hlist);
      xasx := complines(xbook,hlist);
      findtitle(hlist);
      yasy := complines(ybook,hlist);
      gettitleline(xbook,ybook,hlist);
      findtitle(hlist);
      yasx := complines(ybook,hlist);
      findtitle(hlist);
      xasy := complines(xbook,hlist);
      if not xasx
         then writeln(output,
            ' xbook input file does not correspond to xbook in hlist.');
      if not yasy
         then writeln(output,
            ' ybook input file does not correspond to ybook in hlist.');
      if xasy and (not xasx)
         then writeln(output,
            ' xbook input file corresponds to ybook in hlist.');
      if yasx and (not yasy)
         then writeln(output,
            ' ybook input file corresponds to xbook in hlist.');
      if xasy and yasx and (not xasx) and (not yasy)
         then writeln(output,
            ' xbook and ybook input files are reversed. try again.');
      if not (xasx and yasy)
         then halt
end; (* hlistvsbooks *)
(* end module hlistvsbooks version = 'auxmod 1.39 86 dec 12 gds/tds'; *)

(* begin module initialize *)
procedure initialize;
(* set up all the variables *)


const
      missingparam = ' keymatp is missing some parameters.'; (* saves space *)

var
      i: integer;         (* index for counting lines in hlist *)
      getenergy: boolean; (* do we want to get energies?  this is used only
                             to check that minlenmaxene is consistent with
                             the hlist *)
      hlistminmax: real;  (* the minlenmaxene from hist for comparison
                             to the minlenmaxene from keymatp *)

begin (* initialize *)
      writeln(output,' keymat ',version:4:2);
      brinit(xbook);
      brinit(ybook);

      hlistvsbooks(hlist,xbook,ybook);
      reset(hlist);
      rewrite(kmlist);

      new(xseq);          (* new pieceptrs for the sequences *)
      new(yseq);

      (* put header in kmlist *)
      writeln(kmlist,' keymat ',version:4:2,' from:');
      if copylines(hlist,kmlist,headerlines) <> headerlines then begin
         writeln(output,' hlist is too short to even have a correct header');
         halt
      end;

      (* read minlenmaxene from hlist *)
      reset(hlist);
      for i := 1 to 3 do readln(hlist);
      readln(hlist,hlistminmax);
      readln(hlist);
      get(hlist); (* skip the blank *)
      if hlist^ = 'e' then getenergy := true
                      else getenergy := false;
      for i := 6 to headerlines do readln(hlist);

      (* read parameters *)
      reset(keymatp);
      if eof(keymatp) then begin    (* nothing in keymatp so use defaults *)
         minlenmaxene:= hlistminmax;
         xscale:=1;
         yscale:=1;
         gensymbol:='n';
         erange := 'n'
      end
      else begin
         readln(keymatp,minlenmaxene);
         if minlenmaxene > 0 then  (* check to make sure it is an integer*)
            if ((trunc(minlenmaxene) mod 1) <> 0) then begin
               writeln(output,' non-integer length requested in keymatp');
               halt
            end;

         (* check to make sure energies are in hlist if requested *)
         if not (getenergy) then if minlenmaxene < 0 then begin
            writeln(output,' no energies listed in this hlist,');
            writeln(output,' change parameter to request');
            writeln(output,' positive lengths.');
            halt
         end;

         (* check keymatp minlenmaxene against hlists *)
         if minlenmaxene > 0 then if minlenmaxene < hlistminmax then begin
            writeln(output,' caution:');
            write  (output,' hlist only has helices that are');
            writeln(output,' ',trunc(hlistminmax):1,' bases or longer.');
            writeln(output,' ',trunc(minlenmaxene):1,' bases was requested.');
            writeln(output);
            minlenmaxene:= hlistminmax
         end;
         if minlenmaxene <= 0 then if minlenmaxene > hlistminmax then begin
            writeln(output,' caution:');
            write  (output,' hlist only has helices that are');
            writeln(output,' stronger than or equal to ',
                           hlistminmax:5:2,' kcals.');
            writeln(output,' ',minlenmaxene:5:2,' kcal was requested.');
            writeln(output);
            minlenmaxene:= hlistminmax
         end;

         (* get other parameters *)
         if eof(keymatp) then begin
            writeln(output,missingparam);
            halt
         end
         else read(keymatp,xscale);
         if eoln(keymatp) or eof(keymatp) then begin
            writeln(output,' missing the y-scaling parameter in keymatp.');
            writeln(output,' keymatp must contain x and y scaling factors.');
            halt
         end
         else readln(keymatp,yscale);
         if (xscale<0) or (yscale<0) then begin
            writeln(output,' scaling parameters must be positive integers.');
            halt
         end;

         if eof(keymatp) then begin
            writeln(output,missingparam);
            halt
         end
         else begin
            while ((keymatp^=' ') and (not eoln(keymatp))) do get(keymatp);
            if not eoln(keymatp)
            then readln(keymatp,gensymbol)
            else begin
               writeln(output,missingparam);
               halt
            end
         end;

         (* check gensymbol *)
         if not (gensymbol in ['n','x','y','e'])
         then begin
           writeln(output,' ''',gensymbol,''' is not a valid symbol-parameter');
           writeln(output,' please correct keymatp.');
           halt
         end;

         (* determine the range of energy plots *)
         if gensymbol = 'e' then begin
            if eof(keymatp) then begin
               writeln(output,missingparam);
               halt
            end;
            readln(keymatp,erange);
            if not(erange in ['n','l','a']) then begin
               writeln(output,' 4th symbol in keymatp must be one of nla.');
               halt
            end;
            if erange = 'a' then begin
               writeln(output,'alphanumerics is not available now');
               writeln(output,'because it bombs for unknown reasons');
               halt
            end
         end
         else erange := 'n' (* default to numerics *)
      end;

      (* note parameters to kmlist *)
      if minlenmaxene > 0
      then writeln(kmlist,' ',trunc(minlenmaxene):1,
                     ' base pairs is the shortest length helix printed.')
      else writeln(kmlist,' ',minlenmaxene:5:2,
                     ' kcal is the weakest energy helix printed.');
      writeln(kmlist,' ',xscale:1,' ',yscale:1,
               ' are the x and y scaling factors, respectively.');
      if (xscale > 1) or (yscale > 1)
      then writeln(kmlist,' ''*'' indicates helices in this region.')
      else begin
         if gensymbol = 'n'
         then begin
            writeln(kmlist,' n(umber) symbol-type chosen');
            writeln(kmlist);
            writeln(kmlist,' symbols used:');
            write(kmlist,' ',nodot,' every helix thru this point is ');
            if minlenmaxene > 0
            then writeln(kmlist,'less than ',trunc(minlenmaxene):1,
                         ' base pairs long.')
            else writeln(kmlist,'weaker than ',minlenmaxene:5:2,' kcals');
            writeln(kmlist,' 1 gt base pair');
            writeln(kmlist,' 2 at base pair');
            writeln(kmlist,' 3 gc base pair');
         end
         else if gensymbol = 'x'
         then begin
            writeln(kmlist,' x-book bases will be printed in helices.');
         end
         else if gensymbol = 'y'
         then begin
            writeln(kmlist,' y-book bases will be printed in helices.');
         end
         else if gensymbol = 'e'
         then begin
            writeln(kmlist,' e(nergy) of each helix will be printed.');
            write(kmlist,' ');
            case erange of
               'a': write(kmlist,'a(lphanumerics) a to z, 0 to 9'); 
               'l': write(kmlist,'l(etters) a to z'); 
               'n': write(kmlist,'n(umbers) 0 to 9'); 
            end;
            writeln(kmlist,' is the range for the energy display');
         end
         else begin
            writeln(output,' something is wrong in the end of initialize');
            halt
         end;
         writeln(kmlist)
      end
end; (* initialize *)
(* end module initialize *)

(* begin module findcolon *)
procedure findcolon(var thefile: text);
(* move the file to the characters just past ': ' (colon, space) *)
var
      found: boolean;
procedure die;
begin writeln(output,' no helix list data'); halt end;
begin
      found:=false;
      while not found do begin
         if eof(thefile)
            then die
            else if thefile^ = ':'
               then begin
                  get(thefile);
                  if eof(thefile)
                     then die
                     else if thefile^ = ' '
                        then begin
                           get(thefile);
                           found:=true
                        end
               end
               else get(thefile)
      end
end;
(* end module findcolon version = 'auxmod 1.39 86 dec 12 gds/tds'; *)

(* begin module getlowenergy *)
procedure getlowenergy(var hlist: text; var absbottom: real);
(* this procedure will get the lowest energy listed in hlist
   and assign it to absbottom. it uses the keymat global constant-
   headerlines for the number of lines to skip in hlist to get to
   the helix data. *)

var
      i: integer;          (* a counter and dummy length holder *)
      holdenergy: real;    (* a variable to hold energies from hlist to
                              compare to find the lowest energy *)
      done: boolean;       (* signal for ending a loop *)

begin (* getlowenergy *)
      reset(hlist);
      for i:=1 to (headerlines+1) do readln(hlist);
      absbottom:=0;
      done:=false;
      if eof(hlist) then begin
         writeln(output,' no helix data in hlist.');
         halt
      end;
      while not done do begin
         get(hlist); (* skip the blank *)
         if hlist^ <> ' ' then readln(hlist); (* skip over lines that
         separate sequences in multiple sequence hlists *)
         if eof(hlist) then done:= true
         else begin
            for i:=1 to 3 do findcolon(hlist);
            read(hlist,i);  (* a dummy read to skip over the length *)
            readln(hlist,holdenergy);
            if holdenergy < absbottom then absbottom:=holdenergy;
            if eof(hlist) then done:=true
         end
      end;
      reset(hlist);
      for i:=1 to headerlines do readln(hlist) (* get hlist ready to makelist *)
end; (* getlowenergy *)
(* end module getlowenergy *)

(* begin module maketable *)
procedure maketable(abstop,absbottom,subtop,subbottom:real;
                    var symbols: symbolholder; var stops: stopholder;
                    var kmlist: text);

(* maketable will actualy make the assignments to symbols and stops and
   print out the symbol table key to kmlist.  for a definition of all the
   variables see procedure  dotable and procedure  makelist. *)

const
      delta= 0.01;    (* this separates the stop of 1 rangewidth from the
                         start of the next.
                         ex.           2.01  to 3.00  --  'a'
                                       3.01  to 4.00  --  'b'
                         and so on *)
      abovesub='>';  (* character to print for a helix w/ energy>subtop *)
      belowsub='<';  (* character to print for a helix w/ energy<subbottom *)

var
      top,           (* the top of the range - abstop or subtop *)
      bottom,        (* the bottom of the range - absbottom or subbottom *)
      range,         (* difference between top and bottom *)
      rangewidth,    (* range per symbol *)
      start,         (* start value of range per symbol *)
      stop: real;    (* stop value of range per symbol *)

      symb: char;    (* the symbol which will represent an energy value *)

      numbsymb,      (* the number of symbols to be used in the energy table *)
      i,j: integer;    (* just counters *)

      done,          (* whether or not to drop out of a loop *)
      sub: boolean;  (* whether or not subrange was requested *)

begin (* maketable *)

      (* clear stops and symbols *)
      for i:= 1 to 37 do begin
         symbols[i]:='?';
         stops[i]:=0
      end;

      (* find whether or not subrange mode is requested *)
      if (subtop=0) and (subbottom=0) then sub:=false else sub:=true;

      (* assign number of symbols according to erange type *)
      if erange='n'
      then numbsymb:=9
      else if erange='l'
         then numbsymb:=26
         else if erange='a'
            then numbsymb:=35
            else begin
               writeln(output,' problem assigning numbsymb in maktable.');
               halt
            end;

      (* define the range and calculate the rangewidth *)
      if not sub   (* subrange not requested *)
      then begin
         top:= abstop;
         bottom:= absbottom;
      end
      else begin
         top:= subtop;
         bottom:= subbottom;
      end;
      range:= top-bottom;

      (* check to make sure that rangewidth >= delta so each energy symbol
         will have a distinct value. then calculate rangewidth *)
      if range/numbsymb < delta
      then begin
         while range/numbsymb < delta do begin
            numbsymb:=numbsymb-1;
            if numbsymb < 1 then begin
               writeln(output,' range given is too small.');
               halt
            end
         end;
         rangewidth:=delta
      end
      else rangewidth:=((trunc((range/numbsymb)*100))+1)/100;

      (* initialize the correct starts and stops *)
      start:= top;
      stop:= start-rangewidth;
      if erange='n' then symb:='1' else symb:='a';
               (* both l and a erange-types start with a *)
      if sub
      then begin
         for j:=1 to 10 do write(kmlist,' ');
         writeln(kmlist,'above ',start:8:2,'  --  ''',abovesub,'''');
      end;

      (* fill the first place of stops and symbols to account for
         values above the specified range *)
      stops[1]:=start;
      symbols[1]:=abovesub;

      i:=2; (* start the loop with i=2 to allow the first place in both
               stops and symbols to deal with the energies above the
               range selected *)
      done:= false; (* we are not done yet *)

      (* assign the range symbol values while printing the table in kmlist *)
      while not done do begin (* filling symbols and stops *)
         stops[i]:= stop;
         symbols[i]:= symb;
         writeln(kmlist,' ',start:8:2,'    to ',stop:8:2,'  --  ''',symb,'''');
         start:= stop-delta;
         if stop-rangewidth <= bottom
         then begin
         (* to stop loop if you get to bottom of range before last symbol *)
            stop:= bottom;
            if symb='z' then symb:='1' else symb:= succ(symb);
            i:=i+1;
            stops[i]:= stop;
            symbols[i]:= symb;
            writeln(kmlist,' ',start:8:2,'    to ',stop:8:2,
                           '  --  ''',symb,'''');
            done:= true;
         end
         else begin
            stop:= stop-rangewidth;
            if symb='z' then symb:='1' else symb:= succ(symb);
            if i= numbsymb+1 then done:= true else i:= i+1;
         end
      end;

      if sub (* if sub requested assign the last places in stops and symbols *)
      then begin
         for j:=1 to 10 do write(kmlist,' ');
         writeln(kmlist,'below ',bottom:8:2,'  --  ''',belowsub,'''');
      end;
      symbols[i+1]:= belowsub;
      stops[i+1]:= -maxint;
      writeln(kmlist);
      writeln(kmlist,' lowest energy found in hlist was: ',absbottom:8:2);
      writeln(kmlist);
      (* if debug then for i:=1 to 37 do
            writeln(output,' symbol[',i:1,']:''',symbols[i],''',stop: ',
                        stops[i]:5:2); *)
end; (* maktable *)
(* end module maketable *)

(* begin module dotable *)
procedure dotable(var keymatp,kmlist,hlist: text;
                  var symbols: symbolholder;
                  var stops: stopholder);

(* symbols is the array that holds the symbols to print for the various
   different energies, stops is the array that holds the lowest energy
   value for each symbol in symbols. *)

(* dotable will assign the values to stops and symbols, and print the
   energy symbol table key in kmlist. *)

var   abstop,           (* absolute range top value *)
      absbottom,        (* absolute range bottom value *)
      subtop,           (* subrange top value *)
      subbottom: real;  (* subrange bottom value *)

      i: integer;       (* counter *)

procedure yell;
begin
      writeln(output,' incorrect range parameters detected.');
      halt
end;

begin     (* dotable *)

      (* get ranges or set defaults *)
      if minlenmaxene < 0 then abstop:= minlenmaxene else abstop:=0;
      getlowenergy(hlist,absbottom);  (* get lowest energy from hlist *)
      if eof(keymatp)
      then begin     (* no subranges given so use defaults *)
         subtop:=0;
         subbottom:=0  (* when both subtop and subbottom are = 0, that
                           means that subrange mode is not requested *)
      end
      else begin (* read subrange info from keymatp *)
         read(keymatp,subtop);
         while not ((keymatp^ in ['0'..'9']) or (keymatp^='-')) and
            not eoln(keymatp) do get(keymatp);
         if not(eoln(keymatp))  (* found a number *)
            then readln(keymatp,subbottom)
            else yell
      end;

      (* now check the ranges to make sure they are legal energies *)
      if abstop<=0 then if absbottom-abstop>0.0001 then begin
         (* the test is: if the request is for energies
         (abstop < 0) then we should check to see that there will be
         helixes to print.  if absbottom (the lowest energy
         helix in the list) is significantly greater than the
         request, die.  the reason not to do a simple > test is
         that the real numbers involved are from distinct
         sources, and can be the same to several places, yet
         one will be larger than the other.

         if energies are more accurate than the places shown
         above then the number should be altered *)
         writeln(output,' there are no helixes in hlist with energy',
                        ' less than ',absbottom:8:2);
         writeln(output,' your request was for energies ',
            'less than or equal to ',abstop:8:2);
         halt
      end;
      if not(subtop>=subbottom) then yell;
      if (subtop=subbottom) and (subtop<>0) then yell;
      if (subtop<>subbottom)
      then if not((abstop>subtop) and (subbottom>absbottom)) then yell;

      (* now, all the startup is done so it is time to make the
      energy symbol table...*)

      writeln(kmlist,' symbols used:');
      maketable(abstop,absbottom,subtop,subbottom,symbols,stops,kmlist)

end;  (* dotable *)
(* end module dotable *)

(* begin module getrecord *)
procedure getrecord(var freerecord,newhelix:helixptr);
(* get a record to hold a helix from either the freelist or make a new one *)

begin
      if freerecord=nil
      then new(newhelix)
      else begin
         newhelix:= freerecord;
         freerecord:= freerecord^.across;
      end;
      with newhelix^ do begin
         x5pos:=0;
         y3pos:=0;
         length:=0;
         symbol:='?';
         across:=nil
      end
end;
(* end module getrecord *)

(* begin module getholder *)
procedure getholder(var freeholder,newholder:holderptr);
(* get a holder from the freelist or make a new one if one is not available
   from the freelist *)

begin
      if freeholder=nil
      then new(newholder)
      else begin
         newholder:= freeholder;
         freeholder:= freeholder^.down;
      end;
      with newholder^ do begin
         x:=0;
         across:=nil;
         down:=nil;
      end
end;
(* end module getholder *)

(* begin module getsymbol *)
function getsymbol(energy:real; symbols:symbolholder; stops:stopholder):char;
(* getsymbol will return the energy symbol from symbols that corresponds to
   the energy range that the given energy fits in accordng to stops *)

var
      i: integer;    (* index to both stops and symbols *)
      done: boolean; (* when to drop out of loop *)

begin (* getsymbol *)
      if (energy>0) or (energy<-maxint)
      then begin
         write(output,' energy encountered that is out of the range i');
         writeln(output,' can handle.');
         halt
      end;
      i:=1;
      done:=false;
      while not done do begin
(*if debug then writeln(output,' energy is: ',energy:5:2,' stops: ',
                      stops[i]:5:2,' symbols:''',symbols[i],'''  i is: ',i:1);*)
         if energy >= stops[i]
         then begin
            getsymbol:=symbols[i];
            done:=true
         end
         else i:=i+1;
         if i>37 then begin
            writeln(output,' problem in getsymbol.');
            halt
         end
      end
end; (* getsymbol *)
(* end module getsymbol *)

(* begin module readhelix *)
procedure readhelix(var hlist:text; var member:helix;
                    symbols:symbolholder; stops:stopholder;
                    var done:boolean);
(* readhelix will assign the values from hlist to a member of the linked
   list. the done variable will tell makelist when the end of hlist has
   been reached. also, the global constant gensymbol is used to tell if in
   energy mode, and the global variable minlenmaxene is used for screening
   out unwanted helices. symbols and stops are passed so when in energy mode,
   getsymbol can be used to assign a character to the symbol of the helix-
   record. *)

var
      x, y, len:     (* variables to hold helix values while we decide  *)
         integer;    (* to print this helix or not using minlenmaxene param *)
      energy:        (* energy will hold energies from hlist in cases *)
         real;       (* where energies are in hlist *)
      helixok:       (* whether or not to eliminate this helix from printing *)
         boolean;

begin
      x:=0; y:=0; len:=0;  (* just initializing *)
      energy:=0;
      helixok := false;
      repeat
         if eof(hlist)
         then done:= true
         else begin
            get(hlist);
            if hlist^ <>' '
            then done:= true
            else begin
               findcolon(hlist); read(hlist,x);
               findcolon(hlist); read(hlist,y);
               findcolon(hlist); read(hlist,len);
               (* pick up the energy if it is there *)
               if (gensymbol = 'e') or (minlenmaxene < 0)
               then readln(hlist,energy)
               else readln(hlist);
               (* minlenmaxene cannot be <0 without energies being in hlist,
                  this was checked in procedure initialize *)
               (* now decide whether or not to use this helix *)
               if minlenmaxene > 0 then if len >= minlenmaxene
               then helixok := true;
               if minlenmaxene < 0 then if energy <= minlenmaxene
               then helixok := true
            end
         end
      until helixok or done;
      if not done
      then begin
         (* switch to internal coordinates *)
         member.x5pos := pietoint(x,xseq);
         member.y3pos := pietoint(y,yseq);
         (* this changes y5pos from hlist to y3pos needed for keymat! *)
         member.y3pos:= member.y3pos+(len-1);
         (* put in the length *)
         member.length := len;
         (* initialize the pointer *)
         member.across:=nil;
         (* if in energy mode, then get a symbol for the energy char
            else leave a '?' in for the energy symbol *)
         if gensymbol='e'
         then member.symbol:= getsymbol(energy,symbols,stops)
      end
end;
(* end module readhelix *)

(* begin module sortacross *)
procedure sortacross(theholder:holderptr; var newhelix:helixptr);
(* will sort a helix into a row of the linked list... *)

var
      follower: helixptr;     (* just a pointer to follow thru list *)
      done: boolean;          (* when the correct place is found *)

begin
      if newhelix^.y3pos < theholder^.across^.y3pos
      then begin
         newhelix^.across:= theholder^.across;
         theholder^.across:= newhelix
      end
      else begin
         follower:= theholder^.across;
         newhelix^.across:= follower^.across;
         done:= false;
         while not done do begin
            if newhelix^.across = nil
            then done:= true
            else if newhelix^.y3pos < newhelix^.across^.y3pos
               then done:= true
               else begin
                  follower:= follower^.across;
                  newhelix^.across:= newhelix^.across^.across
               end
         end;
         follower^.across:= newhelix
      end
end;
(* end module sortacross *)

(* begin module sorthelix *)
procedure sorthelix(var freeholder,root:holderptr; var newhelix:helixptr);
(* will sort a helix, pointed to by newhelix, into the linked list pointed to
   by root *)

var
      newholder,             (* a pointer for new holders *)
      last,next: holderptr;  (* a pointer to help go thru list *)
      done: boolean;         (* when to leave a loop *)

begin
      if newhelix^.x5pos < root^.x  (* belongs before first member so ... *)
      then begin   (* get a new holder and insert the helix *)
         getholder(freeholder,newholder);
         newholder^.x:= newhelix^.x5pos;
         newholder^.across:= newhelix;
         newholder^.down:= root;
         root:= newholder
      end
      else if newhelix^.x5pos= root^.x  (* belongs on this row so... *)
         then sortacross(root,newhelix)
         else begin
            last:= root;
            next:= root^.down;
            done:= false;
            while not done do begin  (* sort down thru the holders *)
               if next=nil
               then done:= true
               else if next^.x >= newhelix^.x5pos
                  then done:= true
                  else begin
                     last:= next;
                     next:= next^.down
                  end
            end;
            if (next=nil)  (* got to end of list *)
            then begin (* make a new row--get a holder, insert holder + helix *)
               getholder(freeholder,newholder);
               newholder^.x:= newhelix^.x5pos;
               newholder^.across:= newhelix;
               newholder^.down:= next;
               last^.down:= newholder
            end
            else if (next^.x > newhelix^.x5pos) (* belong before this holder *)
            then begin (* make a new row-- ... *)
               getholder(freeholder,newholder);
               newholder^.x:= newhelix^.x5pos;
               newholder^.across:= newhelix;
               newholder^.down:= next;
               last^.down:= newholder
            end
            (* else we are at correct row so insert helix on this row *)
            else sortacross(next,newhelix)
         end
end;
(* end module sorthelix *)

(* begin module makelist *)
procedure makelist(var root,freeholder:holderptr; var freerecord:helixptr;
                   symbols:symbolholder; stops:stopholder);

(* makelist will make the linked list of helices. if the energies
   are to be printed, then symbols and stops that are passed to this
   procedure will be accessed to find the correct symbol to assign to
   each helix when the helix is read in. if not in energy mode, then
   a question mark (?) will be assigned to the symbol variable on each
   helix. global constant listmax is used to limit the size of the list
   listmax may be adjusted to allow for varying amounts of memory
   available to different users.

   a brief description of the list:
      the list consists of a 'root' pointing 'down' to a 'holder'. a holder
   consists of 3 things: (1) a pointer 'across' to a 'helix'---every holder
                             must point to a chain of at least one helix. this
                             what i call a row.
                         (2) an integer which is the x5pos coordinate of the
                             helix that is pointed to by this holder.
                         (3) a pointer 'down' to the next holder, or nil if
                             this is the last holder in the list.
   a helix consists of 5 things:
                         (1) an integer which is the x5pos internal coordinate
                             of the helix it represents.
                         (2) an integer which is the y5pos internal coordinate
                             of the helix it represents.
                         (3) the length of the helix it represents.
                         (4) the symbol to be printed representing the energy
                             of the helix or a question mark if energies are
                             not requested.
                         (5) a pointer 'across' to the next helix in the row
                             or to nil if this is the last helix in this row.
   the helices are first sorted down the holders acording to their x5pos,
   then sorted across a particular row according to their y5pos. if a
   particular holder does not exist at the time a helix needs it, it is
   created and inserted in the proper place.

   if after this wonderful description you are still stymied as to what
   this list looks like in your minds eye, make a diagram, it helps.
   holders were used to avoid putting another pointer on the helix-record.
   this would not only use up more memory, but it complicates the sorting
   algorithm.
*)

var
      newholder: holderptr;   (* pointer for the new holders *)
      newhelix: helixptr;     (* pointer for the new helixes *)
      i,j: integer;           (* counters *)

      done: boolean;          (* when you are done makeing the list *)

begin (* makelist *)
      done:= false;
      (* set up the roots of the lists and place first member in list *)
      getholder(freeholder,root);
      getrecord(freerecord,newhelix);
      readhelix(hlist,newhelix^,symbols,stops,done);
      if done then begin
         writeln(output,' no helices in hlist satisfy parameters.');
         writeln(output,' change parameters to allow helices to be printed.');
         halt
      end;
      root^.x := newhelix^.x5pos;
      root^.across:= newhelix;

      (* make the list *)
      j:=1;
      while (not done) and (j <= listmax) do begin
         getrecord(freerecord,newhelix);
         readhelix(hlist,newhelix^,symbols,stops,done);
         if not done    (* this is an empty record if done *)
         then begin
            sorthelix(freeholder,root,newhelix);
            j := j + 1;
         end
         else begin (* put record back on freelist *)
            newhelix^.across:= freerecord;
            freerecord:= newhelix
         end;
         if j > listmax
         then begin
            writeln(output,' there are more than ',listmax:1,
                           ' helices in hlist.');
            writeln(output,' change parameters to eliminate some helices,');
            writeln(output,' or alter constant listmax.');
            halt
         end
      end

end;
(* end module makelist *)

(* begin module showlist *)
procedure showlist(root: holderptr; var thefile: text);
(* showlist will show the contents of the list to thefile. it is used
   to check the correct functioning of the listmaking procedures *)

var
      row: helixptr;    (* the pointer that will travel across the rows *)
      next: holderptr;  (* the pointer that will travel down column 1 *)

begin
      next:= root;
      while next<> nil do begin
         writeln(thefile,' new row:');
         row:= next^.across;
         write(thefile,' x is: ',inttopie(next^.x,xseq):1);
         while row<> nil do begin
            write(thefile,' x5pos: ',inttopie(row^.x5pos,xseq):1);
            write(thefile,' y3pos: ',inttopie(row^.y3pos,yseq):1);
            write(thefile,' length: ',row^.length:1);
            write(thefile,' next: ');
            row:=row^.across
         end;
         writeln(thefile);
         next:= next^.down;
         if next= nil then writeln(thefile,' reached end of list.');
      end;
      writeln(thefile);
end;
(* end module showlist *)

(* begin module checknames *)
procedure checknames;
(* check that the names in the hlist correspond to those in the books.
   hlist is ready to read the names. *)
begin
      readln(hlist)  (* ignore for now *)
end;
(* end module checknames *)

(* begin module keymat.piecebar *)
procedure piecebar(var afile: text;
                       spaces: integer;
                       pie: pieceptr;
                       firstnumber,lastnumber: integer;
                   var linesused: integer);
(* write a bar of numbers of the piece pie to a file,
with several spaces before.  the number of lines used is returned.
based on procedure numbar.  external procedures required:
  inttopie
  numbersize
  numberdigit
also required is a global variable yscale. yscale defines the scaling of
the piecebar *)
var
      logpower: integer; (* the log of the digit being looked at *)
      spacecount: integer; (* count of spaces *)
      number: integer; (* the current number being written *)
      numbers: file of integer; (* a file for storing all the piece numbers *)
      width: integer; (* the lines used by one number *)
      index: integer; (* to pie *)
      done: boolean; (* when done with the loop *)
begin
      (* calculate lines used and fill up the numbers file *)
      linesused:=0;
      rewrite(numbers);
      index:= firstnumber;
      done:= false;
      while not done do begin
         number:=inttopie(index,pie);
         write(numbers,number);
         width:=numbersize(number);
         if width > linesused then linesused:=width;
         index:= index + yscale;
         if index > lastnumber then done:= true
         (* if yscale does not go evenly into the piece length, then you
            will loose the last scaled divison of the piece *)
      end;

      for logpower:=linesused-1 downto 0 do begin
         for spacecount:=1 to spaces do write(afile,' ');
         reset(numbers);
         while not eof(numbers) do begin
            read(numbers,number);
            write(afile,numberdigit(number,logpower))
         end;
         writeln(afile)
      end
end;
(* end module keymat.piecebar *)

(* begin module keymat.makedna *)
procedure makedna(var afile: text;
                      spaces: integer;
                      pie: pieceptr;
                      firstnumber, lastnumber: integer);
(* write a line of dna to a file, preceeded by several spaces
must also have a global variable - yscale - which will define wether or not
makedna will actualy print the dna. if yscale <> 1 then the dna will not be
printed *)
var
      spacecount: integer; (* count spaces *)
      index: integer; (* to pie *)
begin
      for spacecount:=1 to spaces - 3 do write(afile,' ');
      write(afile,'5',prime,' ');
      if yscale=1 then begin
         for index:=firstnumber to lastnumber
            do write(afile,basetochar(getbase(index,pie)));
      end
      else for index:=firstnumber to (trunc(lastnumber/yscale)+1) do
         write(afile,' ');
      writeln(afile,' 3',prime)
end;
(* end module keymat.makedna *)

(* begin module keymat.makepageheader *)
procedure makepageheader(var pageheader: text);
var
      lines: integer; (* dummy until lines are counted by keymat *)
begin
      rewrite(pageheader);
      page(pageheader);
      writeln(pageheader,' keymat, ',
         ' x down: '  ,xnumber:1,' ',xseq^.key.hea.keynam.letters,
         ' y across: ',ynumber:1,' ',yseq^.key.hea.keynam.letters);
      writeln(pageheader);
      piecebar(pageheader,10,yseq,1,ylength,lines);
      makedna(pageheader,10,yseq,1,ylength);
      writeln(pageheader,'        5',prime);   (* 8 spaces *)
end;
(* end module keymat.makepageheader *)

(* begin module keymat.printpageheader *)
procedure printpageheader(var pageheader: text);
(* print the page header *)
begin
      reset(pageheader);
      while not eof(pageheader) do begin
         while not eoln(pageheader) do begin
            write(kmlist,pageheader^);
            get(pageheader)
         end;
         readln(pageheader);
         writeln(kmlist)
      end
end;
(* end module keymat.printpageheader *)

(* begin module printlist *)
procedure printlist(root,freeholder: holderptr; freerecord: helixptr);
(* printlist will print the list given in kmlist *)

var
      pageheader: text; (* the header for pages of kmlist *)
      bx, by: base;     (* bases at x and y of xseq and yseq respectively *)
      x,y: integer;     (* line and current x position *)
      current: helixptr;(* the current helix being looked at *)

procedure blankrow;
(* write a row of nodots in kmlist *)
begin
      y:=1;
      while y <= ylength do begin
         write(kmlist,nodot);
         y:= y + 1;
      end;
      writeln(kmlist)
end;

procedure writenodots(var y: integer; next: integer);
(* writenodots will start at the current y and write nodots up to but not
   in the "next" position given *)

begin
      while y < next do begin
         write(kmlist,nodot);
         y:= y + 1;
      end;
end;

procedure freer(ptr:helixptr);
(* put a record on the freelist *)
begin
      ptr^.across:= freerecord;
      freerecord:= ptr;
      ptr:= nil;
end;

procedure freeh(var ptr:holderptr);
(* put a holder on the freelist *)
var temp: holderptr; (* a temporary transporter of the holder *)
begin
      temp:= ptr;
      ptr:= ptr^.down;
      temp^.down:= freeholder;
      freeholder:= temp;
      temp^.across:= nil;
end;

begin (* printlist *)
      makepageheader(pageheader);
      x:=1;
      while x <= xlength do begin
         if ((x mod pagelength) = 0) or (x = 1)
            then printpageheader(pageheader);
        (* now print the left side of the list *)
         bx := getbase(x, xseq);
         write(kmlist,' ',inttopie(x,xseq):6,' ');
         write(kmlist,basetochar(bx),' ');

         if root=nil (* if no more helices in the list *)
         then blankrow
         else if x < root^.x    (* no helices on this row *)
            then blankrow
            else begin     (* there are helices on this row so print them *)
               y:=1;    (* keep track of where we are on the current line *)
               while root^.across <> nil do begin
                  current:= root^.across;
                  writenodots(y,current^.y3pos);

                  (* got to the right spot, now print the correct symbol *)
                  if gensymbol='e' (* in energy mode so print energy symbol *)
                  then write(kmlist,current^.symbol)
                  else if gensymbol='n'
                  then begin (* make a number at the place *)
                     by := getbase(current^.y3pos, yseq);
                     if bx = complement(by)
                     then case bx of
                        a: write(kmlist,'2');
                        c: write(kmlist,'3');
                        g: write(kmlist,'3');
                        t: write(kmlist,'2');
                     end
                     else write(kmlist,'1') (* for gt pairs *)
                  end
                  else if gensymbol='x'
                     then write(kmlist,basetochar(bx))
                     else if gensymbol='y'
                        then begin
                           by:= getbase(current^.y3pos,yseq);
                           write(kmlist,basetochar(by));
                        end;

                  y:= y + 1;  (* keep track of y *)
                  root^.across:= current^.across; (* set root to next memb *)
                  current^.across:= nil; (* clear the previous across ptr *)
                  with current^ do begin (* deal with helix just printed *)
                     x5pos:= x5pos + 1;
                     y3pos:= y3pos - 1;
                     length:= length - 1;
                  end;
                  if (current^.length < 1) (* done printing this helix *)
                     or (current^.x5pos < (x+1))
                  then freer(current)
                  else sorthelix(freeholder,root,current);
               end;
               while y <= ylength do begin  (* write nodots to end of line *)
                  write(kmlist,nodot);
                  y:= y + 1;
               end;
               writeln(kmlist);   (* finish off line *)
               freeh(root)   (* put holder on freelist *)
            end;
         x:= x+1;
      end;
      writeln(kmlist,'        3',prime);   (* 8 spaces *)
end;
(* end module printlist *)

(* begin module sprintlist *)
procedure sprintlist(var root,freeholder: holderptr;
                     var freerecord: helixptr);

(* sprintlist will print the list scaled in kmlist *)

var
      pageheader: text; (* the header for pages of kmlist *)
      bx, by: base;     (* bases at x and y of xseq and yseq respectively *)
      x,y,l: integer;   (* current piece positions and line counter *)
      factor: integer;  (* factor by which to change helix values *)
      current: helixptr;(* the current helix being looked at *)
      currenth: holderptr;(* the current holder being looked at *)
      donerow,          (* whether or not finished printing a row in kmlist *)
      donebox,          (* whether or not finished searching list for one box
                           in kmlist *)
      doneline,         (* whether or not finished searching a line of the
                           list *)
      printstate:       (* whether or not to print a dot in this position of
                           kmlist for a helix *)
         boolean;

procedure blankrow;
(* write a row of nodots in kmlist *)
begin
      y:=1;
      while y <= ylength do begin
         write(kmlist,nodot);
         y:= y + yscale;
      end;
      writeln(kmlist)
end;

procedure freer(var hptr: holderptr; var rptr: helixptr);
(* freer will either sort a helix back into the list or will put the helix
   record back on the freelist depending on whether or not you are finished
   printing the helix. this is determined by the length of the helix. if
   the length < 1 then we are finished with this helix. *)

var ptr: helixptr;  (* a pointer to help in removing record *)

procedure loopnfree(var ptr1,ptr2: helixptr);
(* loopnfree will loop out record and do the free or sort *)

begin
      ptr1 := ptr2^.across;
      ptr2^.across := nil; (* now ptr2^ is free of all ties to the list *)
      if ptr2^.length < 1
      then begin
         ptr2^.across := freerecord;
         freerecord := ptr2
      end
      else sorthelix(freeholder,root,ptr2);
      ptr2 := ptr1
end;

begin (* freer *)
      if hptr^.across = rptr  (* if rptr is on first member of 'line' *)
      then loopnfree(hptr^.across,rptr)
      else begin
         ptr := hptr^.across;
         while ptr^.across <> rptr do
            ptr := ptr^.across;
         loopnfree(ptr^.across,rptr)
      end
end; (* freer *)

procedure freeh(var root,hptr: holderptr);
(* freeh will loop a holder out of the list and put it on the free-holder
   list, then set the pointer to that holder to the next holder down. *)

var ptr: holderptr;  (* a pointer to help in removing holder *)

procedure hloopnfree(var hptr1,hptr2: holderptr);
(* hloopnfree will loop out holder *)

begin
      hptr1 := hptr2^.down;
      hptr2^.down := freeholder;
      freeholder := hptr2;
      hptr2 := hptr1
end;

begin (* freeh *)
      if root = hptr  (* if hptr is on first holder of list *)
      then hloopnfree(root,hptr)
      else begin
         ptr := root;
         while ptr^.down <> hptr do
            ptr := ptr^.down;
         hloopnfree(ptr^.down,hptr)
      end
end; (* freeh *)

begin (* sprintlist *)
      makepageheader(pageheader);
      x:=1;   (* start at the beginning of the xseq *)
      l:=1;   (* starting on the first line *)
      while x <= xlength do begin
         if ((l mod pagelength) = 0) or (l = 1)
            then printpageheader(pageheader);
        (* now print the left side of the list *)
         bx := getbase(x, xseq);
         write(kmlist,' ',inttopie(x,xseq):6,' ');
         if xscale=1
         then write(kmlist,basetochar(bx))
         else write(kmlist,' ');
         write(kmlist,' ');  (* space *)

         if root=nil (* if no more helices in the list *)
         then blankrow
         else if (x + xscale-1) < root^.x    (* no helices on this row *)
         then blankrow
         else begin     (* there are helices on this row so print them *)
            y:=1;    (* keep track of where we are on the current line *)
            donerow := false;
            currenth := root;
(*if debug then writeln(output,' starting row: ',inttopie(x,xseq)); *)
            while not(donerow) do begin
               donebox := false;
               printstate := false;

(*if debug then writeln(output,' starting box: ',inttopie(y,yseq)); *)
               while not(donebox) do begin
                  (* check if currenth^.x is past the bottom of this box *)
                  if currenth = nil then donebox := true
                  else if currenth^.x > (x + xscale-1) then donebox := true
                  else begin
                     current := currenth^.across;
                     doneline := false;

(*if debug then writeln(output,' starting line: ',inttopie(currenth^.x,xseq));
*)
                     while not(doneline) do begin
(*if debug then if current <> nil
then writeln(output,' current^.y3pos is: ',inttopie(current^.y3pos,yseq));*)
                        if current = nil  (* end of line of list *)
                        then doneline := true
                        else if current^.y3pos >
                                y+(yscale-1)+(xscale-1)-(current^.x5pos-x)
                        (* not possible for any helixes further out to be
                            in the box *)
                        then doneline := true
                        else if current^.y3pos <= y+(yscale-1)
                        (* if start of helix is in the box *)
                        then begin  (* change values of current helix *)
(*if debug then writeln(output,' start of helix is in the box.'); *)
                           printstate := true;
                           factor:= x + xscale - current^.x5pos ;
                           with current^ do begin
                              x5pos:= x5pos + factor;
                              y3pos:= y3pos - factor;
                              length:= length - factor
                           end;

                           (* sort or free current depending on whether
                              finished printing and set current to next
                              member of the list *)
                           freer(currenth,current)
                        end
                        else if current^.length >=
                                current^.y3pos-(y+(yscale-1))+1
                        (* start is out of box but length brings helix into
                           this box do not change or sort this type of helix,
                           it will be done in the next box *)
                        then begin
(*if debug then begin
write(output,' start of helix is out of the box,');
writeln(output,' but length brings it in.')
end;  *)
                           printstate := true;
                           (* set current to next memb of list *)
                           current := current^.across
                        end
                        (* if current helix is not in nor will pass into box
                           then set current to next memb of list *)
                        else current := current^.across
                     end; (* doneline *)

(*if debug then begin
writeln(output,' doneline,  printstate is: ',printstate);
writeln(output,'     ''   , currenth^.x is: ',inttopie(currenth^.x,xseq));
writeln(output)
end;  *)

                     if currenth^.across = nil
                     (* this holder is empty due to printing *)
                     then freeh(root,currenth)
                     else currenth := currenth^.down;
                     (* else set currenth to next holder down *)
                  end
               end; (* donebox *)

(*if debug then begin
writeln(output,' donebox,  printstate is: ',printstate);
writeln(output,'    ''   , x is: ',inttopie(x,xseq),' y is: ',inttopie(y,yseq));
writeln(output);  writeln(output);  writeln(output)
end;  *)

               if printstate then write(kmlist,'*') else write(kmlist,nodot);
               y := y + yscale; (* move across to next box *)
               currenth := root; (* start at top of box *)
               if y > ylength then donerow := true;
            end; (* donerow *)
            writeln(kmlist);   (* finish off line *)

(*if debug then begin
writeln(output,' donerow, currenth^.x is: ',inttopie(currenth^.x,xseq));
writeln(output);  writeln(output);  writeln(output);  writeln(output);
writeln(output); showlist(root,output)
end;  *)
         end;
         x := x + xscale;
         l := l + 1;
      end;
      writeln(kmlist,'        3',prime);   (* 8 spaces *)
end;
(* end module sprintlist *)

(* begin module printmatrix *)
procedure printmatrix(symbols:symbolholder; stops:stopholder);
(* symbols and stops are global variables and are passed into printmatrix
   so as not to be changed. these variables are initialized in the dotable
   procedure. they are the tables for getting energy symbols. *)

var
      root,           (* root of the list *)
      freeholder:     (* root of the holder freelist *)
         holderptr;
      freerecord:     (* root of the record freelist *)
          helixptr;

begin
      root:=nil;
      freeholder:=nil;
      freerecord:=nil;

      checknames;
      makelist(root,freeholder,freerecord,symbols,stops);
      if debug then showlist(root,output);
      if (xscale > 1) or (yscale > 1)
      then sprintlist(root,freeholder,freerecord)
      else printlist(root,freeholder,freerecord)
end;
(* end module printmatrix *)

(* begin module blank *)
procedure blank(symbols:symbolholder; stops:stopholder);
(* initialize symbols to all '?' and stops to zeros *)

var i: integer;   (* counter and index *)

begin
      for i := 1 to 37 do begin
         symbols[i] := '?';
         stops[i] := 0;
      end
end;
(* end module blank *)

begin (* keymat *)
      initialize;
      (* make energy tables if necessary *)
      if gensymbol='e'
      then dotable(keymatp,kmlist,hlist,symbols,stops)
      else blank(symbols,stops);

      while not eof(xbook) do begin
         getpiece(xbook,xseq);
         xnumber:=number;
         xlength:=piecelength(xseq);
         if not eof(xbook) then begin
            reset(ybook);
            while not eof(ybook) do begin
               getpiece(ybook,yseq);
               ynumber:=number;
               ylength:=piecelength(yseq);
               if not eof(ybook) then begin
                  printmatrix(symbols,stops);
                  clearpiece(yseq)
               end
            end;
            clearpiece(xseq)
         end
      end;
1: end. (* keymat *)