program bookshift(book, inst, bookshiftp, bookout, output);
(* bookshift: shift the coordinates in a book according to an inst

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

  Uses module delmod.

 *)

label 1; (* end of program *)

const
(* begin module version *)
   version = 1.12; (* of bookshift.p 2004 Sep 8
2004 Sep  8, 1.12: clean up for GPC
2004 Jan 18, 1.11: bug solved, cleanup
2004 Jan 17, 1.10: tracking bug in complementary cases
2004 Jan 14, 1.09: document cleanup
2004 Jan 14, 1.08: functional
2004 Jan 14, 1.07: read the inst directly by using trigger
2004 Jan 14, 1.06: use a simple read mechanism.  the getocp
                   routine is designed for reading, not output.
2004 Jan 14, 1.05: may need ocp for both in and out books???
2004 Jan 13, 1.04: getocp fixed
2004 Jan 13, 1.03: getocp beginning to function
2004 Jan 13, 1.02: getocp beginning to function
2004 Jan 13, 1.01: getocp being imported from delmod.p
2004 Jan 13, 1.00: origin
*)
updateversion = 1.00; (* defines lowest acceptable current parameter file *)
(* end module version *)

(* begin module describe.bookshift *)
(*
name
   bookshift: shift the coordinates in a book according to an inst

synopsis
   bookshift(book, inst: in, bookshiftp: in, bookout: out, output: out)

files

   book:  A book from the delila system, aligned by the inst file

   inst:  The delila instructions used to create the book.

      The delila instructions are of the form 'get from 56 -5 to 56 +10;'
         If this file is empty, then the sequences will be
         aligned either by their 5' ends or by their zero base,
         depending on the 4th parameter in bookshiftp.

      book: the book generated by delila using inst.

   bookshiftp:  parameters to control the program.  The file must contain the
      following parameters, one per line:

      parameterversion: The version number of the program.  This allows the
         user to be warned if an old parameter file is used.

      The following parameter is required but only type 'i' has been
      implemented:

      The method of alignment, alignmenttype.  See program alist for
      further details.

         If the first character is
         'f' (for 'first') then the sequences are always aligned by their
         first base.

         'i' then the sequences are aligned by the delila instructions.  If
         the inst file is empty, alignment is forced to the 'b' mode.

         'b' (for 'internal') then the alignment is on the internal zero of
         the book's sequence.  This option is to be used when "default
         coordinate zero" is used in the Delila instructions.

   bookout: the book, realigned according to the inst.

   output: messages to the user

description

   After constructing a model of a binding site one would like to know
   something about the density of that or other sites relative to the
   binding site.  This can be done by scanning a Delila book which has
   an alignment so that the site zero base becomes the zero of each
   piece in the book.  Then when the pieces are scanned, the
   coordinates are all common.  The results of the scan can be plotted
   using the denplo program.

   Delila books can be assigned an alignment by an instruction file,
   but this preserves the original coordinate system in the book.  The
   scan program (and biscan or multiscan) are not designed to use an
   inst file to align the results.

   Instead, the sequences in a book can be realigned by using the
   Delila instruction "set coordinate zero;" which then causes each
   output piece to have a zero according to the 'from' of the
   corresponding get instruction in the inst file.  While changing the
   inst file and rerunning Delila is practical in most cases, some
   books built from whole genomes are extremely large, making it
   difficult to realign.

   The purpose of this bookshift program is to take an aligned set of
   sequences (the book/inst pair) and create a new book, bookout, in
   which each piece has a zero base set according to the inst.

examples

documentation

see also

   {shifting Delila instructions instead of a book:} instshift.p
   {scanning programs: } scan.p multiscan.p
   {plotting program: } denplo.p
   {check book/inst alignment: } alist.p
   {program used to get the basis of this one: } range.p
   {source for better get scanning: } delmod.p

author

   Thomas Dana Schneider

bugs

   The mechanism to read the inst file is not robust and will fail if
   the word 'get' is inside comments or quotes.  This can be fixed by
   taking code from procedure align in delmod.p

technical notes

*)
(* end module describe.bookshift *)

(* begin module book.const *)
(* constants needed for book manipulations *)
      dnamax = 1024;  (* length of dna arrays *)
      namelength = 100; (* maximum key name length *)
      linelength = 80; (* maximum line readable in book *)
(* end module book.const version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module interact.const *)
(* begin module string.const *)
      maxstring = 150; (* the maximum string *)
(* end module string.const version = 4.39; (@ of prgmod.p 1999 November 28 *)
(* end module interact.const version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module filler.const *)
      fillermax = 50; (* the size of the filler array for a string *)
(* end module filler.const version = 4.18; (@ of prgmod.p 1996 September 12 *)

type
(* begin module interact.type *)
(* begin module string.type *)
   stringptr = ^string; (* pointer to a string *)
   string = record (* a string of characters *)
      letters: array[1..maxstring] of char; (* the letters in the string *)
      length: integer; (* the number of characters in the string *)
      current: integer; (* the letter we are working on *)
      next: stringptr; (* the next string in a series *)
   end;
(* end module string.type version = 4.39; (@ of prgmod.p 1999 November 28 *)
(* end module interact.type version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module filler.type *)
      (* the following is an array used to fill a string.
      it is convenient to have it much shorter than the maxstring, so that
      it is easy to fill the string using procedure fillstring.
      the user must declare the value of constant fillermax. *)
      filler = packed array[1..fillermax] of char;
(* end module filler.type version = 4.18; (@ of prgmod.p 1996 September 12 *)

(* begin module trigger.type *)
      trigger = record (* an object to be searched for *)
         seek: string; (* the characters looked for *)
         state: integer; (* how close to triggering we are *)
         skip: boolean; (* trigger not found- skip the line *)
         found: boolean (* the trigger was found *)
      end;
(* end module trigger.type version = 4.18; (@ of prgmod.p 1996 September 12 *)

(* 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;

(* begin module base.type *)
   (* define the four nucleotide bases *)
   base = (a,c,g,t);
(* end module base.type version = 7.62; {of delmod.p 2003 Jan 13} *)

      (* sequence types *)
      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 = 7.62; {of delmod.p 2003 Jan 13} *)

var
   book, inst, (* file used by this program *)
   bookshiftp, (* file used by this program *)
   bookout: text; (* file used by this program *)

(* 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 = 7.62; {of delmod.p 2003 Jan 13} *)

(* 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 = 7.62; {of delmod.p 2003 Jan 13} *)

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

(* begin module package.trigger *)
(* ************************************************************************ *)

(* begin module interact.clearstring *)
procedure clearstring(var ribbon: string);
(* empty the string *)
var   index: integer; (* to the ribbon *)
begin (* clearstring *)
      with ribbon do begin
         for index := 1 to maxstring do letters[index] := ' ';
         length := 0;
         current := 0;
      end
end; (* clearstring *)
(* end module interact.clearstring version = 4.18; (@ of prgmod.p 1996 September 12 *)

(* begin module interact.writestring *)
procedure writestring(var tofile: text; var s: string);
(* write the string s to file tofile, no writeln *)
var   i: integer; (* index to s *)
begin (* writestring *)
      with s do for i := 1 to length do write(tofile, letters[i])
end; (* writestring *)
(* end module interact.writestring version = 4.18; (@ of prgmod.p 1996 September 12 *)

(* begin module filler.fillstring *)
procedure fillstring(var s: string; a: filler);
(* this procedure makes it reasonably easy to fill the string s with
characters.  one calls the procedure as: *)
(*                           1         2         3         4         5 *)
(*                  12345678901234567890123456789012345678901234567890 *)
(*   fillstring(s, 'this-is-the-string                                ');
the two comments make it easy to line the characters up. also, for this
example, it was assumed that the length of filler as defined by the
constant fillermax was 50. *)
var
      length: integer; (* of the string without trailing blanks *)
      index: integer; (* of s *)
begin (* fillstring *)
      clearstring(s);
      length := fillermax;
      while (length > 1) and (a[length] = ' ') do length := pred(length);
      if (length = 1) and (a[length] = ' ') then begin
         writeln(output, 'fillstring: the string is empty');
         halt
      end;

      for index := 1 to length do s.letters[index] := a[index];
      s.length := length;
      s.current := 1
end; (* fillstring *)
(* end module filler.fillstring version = 4.18; (@ of prgmod.p 1996 September 12 *)

(* begin module filler.filltrigger *)
procedure filltrigger(var t: trigger;
                      a: filler);
(* fill the trigger t *)
begin (* filltrigger *)
         fillstring(t.seek,a)
end; (* fillstring *)
(* end module filler.filltrigger version = 4.18; (@ of prgmod.p 1996 September 12 *)

(* begin module trigger.proc *)
(* this module allows one to scan a series of characters, as from
an array or a file, and to "trigger" or detect a simple string
in the series.  the advantage of the trigger is that several triggers
can "observe" a stream of characters at once, each looking for a
different thing.
some other modules required: interact.const, interact.type *)

procedure resettrigger(var t: trigger);
(* reset the trigger to ground state *)
begin (* resettrigger *)
      with t do begin
         state := 0;
         skip := false;
         found := false
      end
end; (* resettrigger *)

procedure testfortrigger(ch: char; var t: trigger);
(* look at the character ch.
   if it is part of the trigger (at the current trigger state),
       then the trigger state goes higher.
   if it is not part of the trigger then the trigger state is reset,
      skip is true and one should skip onward to find the trigger.
   if the trigger is found, found is true.
1996 Sep 12: Bug found!  In the case of a trigger "ab", the program
used to miss it for situations like "aab".  This was because at the
first a it would step up.  Then it would see the second a and recognize
that was not part of ab.  It would fail to realize that it could be
the start of a new one.  The code now accounts for that possibility. *)
begin (* testfortrigger *)
      with t do begin
         state := succ(state);
{
writestring(list,seek);
writeln(list,'testfortrigger seek.letters[',state:1,']:',
seek.letters[state],' ch:',ch);
}
         if seek.letters[state] = ch
         then begin
            skip := false;
            if state = seek.length then found := true
                                   else found := false
         end
         else begin
            (* it failed.  But wait!  It could be the beginning
            of a NEW trigger string! *)
            if seek.letters[1] = ch then begin
               state := 1;
               skip := false;
               found := false
            end
            else begin (* reset trigger *)
               state := 0;
               skip := true;
               found := false
            end
         end
      end
end; (* testfortrigger *)
(* end module trigger.proc version = 4.18; (@ of prgmod.p 1996 September 12 *)

(* begin module skipblanks *)
procedure skipblanks(var thefile: text);
(* skip over blanks until a non-blank, or end of line, is found *)
begin
      while (thefile^ = ' ') and not eoln(thefile) do get(thefile);
end;

procedure skipnonblanks(var thefile: text);
(* skip over nonblanks until a blank, or end of line, is found *)
begin
      while (thefile^ <> ' ') and not eoln(thefile) do get(thefile);
end;

procedure skipcolumn(var thefile: text);
(* skip over a data column *)
begin
   skipblanks(thefile); skipnonblanks(thefile)
end;
(* end module skipblanks version = 4.18; (@ of prgmod.p 1996 September 12 *)

(* ************************************************************************ *)
(* end module package.trigger version = 4.18; (@ of prgmod.p 1996 September 12 *)

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

(* 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 writeline(var afile: text; l: lineptr;
                        carriagereturn: boolean);
(* write a line to a file, with carriage return if
carriagereturn is true. *)
var
   index: integer; (* index to characters in l *)
begin
   with l^ do begin
      for index := 1 to length
      do write(afile, letters[index]);
   end;
   if carriagereturn then writeln(afile);
end;

procedure showfreedna;
(* show the freedna list *)
var
   counter: integer; (* count of freedna list *)
   l: dnaptr; (* pointer into freedna list *)
begin
   l := freedna;
   counter := 0;
   while l <> nil do begin
      counter := succ(counter);
      write(output,counter:1);
      write(output, ', length = ',l^.length:1);
{
This is illegal according to gpc because one cannot
write a pointer to a text file.  It can be unearthed
for debugging.
      write(output, ', pointer id: ',l:1);
}
      writeln(output);
      l := l^.next
   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 chomplement(b: char): char;
(* create the character complement of base b.  I must be getting hungry! *)
begin
  chomplement := basetochar(complement(chartobase(b)));
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 *)
(* Note: the dirhomologous and dircomplement are treated as
plus and minus directions, which MIGHT NOT BE RIGHT! *)
var   i: integer; (* an intermediate value *)
begin
      with pie^.key do begin
         case piedir of
            dirhomologous,
            plus:  if p>=piebeg
                   then i:=p-piebeg+1
                   else i:=(p-coobeg)+(cooend-piebeg)+2;
            dircomplement,
            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 *)
(* Note: the dirhomologous and dircomplement are treated as
plus and minus directions, which MIGHT NOT BE RIGHT! *)
var   p: integer; (* an intermediate value *)
begin
      with pie^.key do begin
         case piedir of
            dirhomologous,
            plus: begin
               p:=piebeg+(i-1);
               if p>cooend
                  then if coocon=circular
                     then p:=p-(cooend-coobeg+1)
            end;
            dircomplement,
            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 = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.getto *)
function getto(var thefile: text; var theline: integer; ch: chset): char;
(* search the file for a character in the first line which is a
   member of the set ch.
Note:  on 1999 March 10 the definition of this function was cleaned
up.  Instead of putting thefile on the line AFTER the charcter ch
has been found, it puts thefile ON the line.  Other routines like
brdna and brpiece have to move to the next line themselves.  This makes
getto give the OBJECT.  *)
var
   achar: char; (* a character in thefile *)
   done: boolean; (* done finding achar *)
begin
   achar:=' ';
   done := false;
   while not done do begin
      if eof(thefile)
      then done := true
      else begin
         achar := thefile^;
         if achar in ch
         then done := true
         else begin
            readln(thefile);
            theline := succ(theline)
         end
      end
   end;
   if (achar in ch) then getto:=achar
                    else getto:=' '
{ The old method -
      while (not(achar in ch)) and (not eof(thefile))
         do begin
            readln(thefile,achar);
            theline := succ(theline)
         end;
   if (achar in ch) then getto:=achar
                    else getto:=' '
}
end;
(* end module book.getto version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.skipstar *)
procedure skipstar(var thefile: text);
(* skip start of line (or star = '*'). *)
begin (* skipstar *)
   if eof(thefile) then begin
      writeln(output,' procedure skipstar: end of book found');
      halt
   end
   else begin
      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
end; (* skipstar *)
(* end module book.skipstar version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brreanum *)
procedure brreanum(var thefile: text; var theline: integer; var reanum: real);
(* read a real number from the file *)
begin
      skipstar(thefile);
      readln(thefile,reanum);
      theline := succ(theline)
end;
(* end module book.brreanum version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brnumber *)
procedure brnumber(var thefile: text; var theline: integer; var num: integer);
(* read a number from the file *)
begin
      skipstar(thefile);
      readln(thefile,num);
      theline := succ(theline)
end;
(* end module book.brnumber version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brname *)
procedure brname(var thefile: text; var theline: integer; 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);
      theline := succ(theline)
end; (* brname *)
(* end module book.brname version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brline *)
procedure brline(var thefile: text; var theline: integer; var l: lineptr);
(* read a line from the file *)
var
      i: 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;
      l^.length:=i;
      l^.next:=nil;
      readln(thefile);
      theline := succ(theline)
end;
(* end module book.brline version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brdirect *)
procedure brdirect(var thefile: text; var theline: integer; var direct: direction);
(* read a direction *)
var   ch: char;
begin
      skipstar(thefile);
      readln(thefile,ch);
      theline := succ(theline);
      if ch='+' then direct:=plus
                else direct:=minus
end;
(* end module book.brdirect version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brconfig *)
procedure brconfig(var thefile: text; var theline: integer; var config: configuration);
(* read a configuration *)
var   ch: char;
begin
      skipstar(thefile);
      readln(thefile,ch);
      theline := succ(theline);
      if ch='l' then config:=linear
                else config:=circular
end;
(* end module book.brconfig version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brnotenumber *)
procedure brnotenumber(var thefile: text; var theline: integer; 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);
         theline := succ(theline);
         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);
               theline := succ(theline)
            until thefile^ = 'n';
            readln(thefile);
            theline := succ(theline)
         end
         else begin
            readln(thefile);
            theline := succ(theline)
         end
      end
end; (* brnotenumber *)
(* end module book.brnotenumber version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brnote *)
procedure brnote(var thefile: text; var theline: integer; 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);
         theline := succ(theline);
         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,theline,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);
            theline := succ(theline);
         end
         else begin
            readln(thefile);
            theline := succ(theline);
         end;
      end
end; (* brnote *)
(* end module book.brnote version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brheader *)
procedure brheader(var thefile: text; var theline: integer; var hea: header);
(* read the header of a key. *)
begin
      with hea do begin
         readln(thefile); (* move past the object name - new definition 1999 Mar 13 *)
         theline := succ(theline);
{bbb}
         (* read key name *)
         brname(thefile,theline,keynam);

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

         (* read note key *)
         if readnumber then brnotenumber(thefile,theline,note)
                       else brnote(thefile,theline,note)
      end
end;
(* end module book.brheader version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.copyheader *)
procedure copyheader(fromhea: header; var tohea: header);
(* copy the header fromhea into tohea.  Note that the
linked objects are NOT copied, but merely pointed to. *)
begin
   tohea.keynam.letters := fromhea.keynam.letters;
   tohea.keynam.length  := fromhea.keynam.length;
   tohea.note           := fromhea.note;
   tohea.fulnam         := fromhea.fulnam;
end;
(* end module book.copyheader version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brpiekey *)
procedure brpiekey(var thefile: text; var theline: integer; var pie: piekey);
(* read piece key, track the line number *)
begin
      with pie do begin
         brheader(thefile,theline,hea);
         brreanum(thefile,theline,mapbeg);
         brconfig(thefile,theline,coocon);
         brdirect(thefile,theline,coodir);
         brnumber(thefile,theline,coobeg);
         brnumber(thefile,theline,cooend);
         brconfig(thefile,theline,piecon);
         brdirect(thefile,theline,piedir);
         brnumber(thefile,theline,piebeg);
         brnumber(thefile,theline,pieend);
      end
end;
(* end module book.brpiekey version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brdna *)
procedure brdna(var thefile: text; var theline: integer; var dna: dnaptr);
(* read in dna from thefile, track the line *)
(* note: if the dna were circularized, by linking the last dnastring
to the first, then the cleardna routine could not clear properly,
and would loop forever... there is no reason to do that, since a simple
mod function will allow one to access the circle. *)
var
      ch: char;
      workdna: dnaptr;
begin
      getdna(dna);
      workdna:=dna;
      ch:=getto(thefile,theline,['d']);
      readln(thefile);
      theline := succ(theline);
      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 *)
         theline := succ(theline);
         read(thefile,ch); (* ch is either '*' or 'd' *)
      end;
      readln(thefile); (* read past the d *)
      theline := succ(theline);
end;
(* end module book.brdna version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brpiece *)
procedure brpiece(var thefile: text; var theline: integer; var pie: pieceptr);
(* read in a piece, change theline to reflect the lines traversed *)
begin
{
   readln(thefile); (* move past the word 'piece' - new definition 1999 Mar 13 *)
   theline := succ(theline); (* BUG: was below! *)
bbb}
   brpiekey(thefile,theline,pie^.key);
   if numbered or (not skipunnum)
   then brdna(thefile,theline,pie^.dna);
   readln(thefile); (* move past the word 'piece' - new definition 1999 Mar 13 *)
   theline := succ(theline);
end;
(* end module book.brpiece version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brinit *)
procedure brinit(var book: text; var theline: integer);
(* 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;
   theline := 1;
end; (* brinit *)
(* end module book.brinit version = 7.62; {of delmod.p 2003 Jan 13} *)

(* ************************************************************************ *)
(* end module package.brpiece version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.getpiece *)
procedure getpiece(var thefile: text; var theline: integer; var pie: pieceptr);
(* move to and read in the next piece in the book *)
var   ch: char;
begin
   ch:=getto(thefile,theline,['p']); (* get to the next p(iece) in the book *)
   if ch<>' ' then begin
      brpiece(thefile,theline,pie);
{
1999 june 2: removed this:
      ch:=getto(thefile,theline,['p']); (* read to end of p *)
}
{
bbb - now done in brpiece
      readln(thefile); (* read past piece *)
      theline := succ(theline);
}
   end
   else clearpiece(pie);
end;
(* end module book.getpiece version = 7.62; {of delmod.p 2003 Jan 13} *)

(* ************************************************************************ *)
(* end module package.getpiece version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module findblank *)
procedure findblank(var afile: text);
(* read a file to find the next blank character *)
var   ch: char;
begin
      repeat read(afile,ch) until ch = ' '
end;
(* end module findblank version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module findnonblank *)
procedure findnonblank(var afile: text; var ch: char);
(* find the next non blank character in a file, return it in ch. *)
begin
      ch:=' ';
      while (not eof(afile)) and
            (ch = ' ')
      do begin
         read(afile,ch);
         if eoln(afile) then readln(afile)
      end
end;
(* end module findnonblank version = 7.62; {of delmod.p 2003 Jan 13} *)

{qqq}

(* begin module book.brorgkey *)
procedure brorgkey(var thefile: text; var theline: integer; var org: orgkey);
(* read organism key *)
begin
      with org do begin
{bbb}
         brheader(thefile,theline,hea);
         getline(mapunit);
         brline(thefile,theline,mapunit);
      end
end;
(* end module book.brorgkey version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.brchrkey *)
procedure brchrkey(var thefile: text; var theline: integer; var chr: chrkey);
(* read chromosome key *)
begin
      with chr do begin
{bbb}
         brheader(thefile,theline,hea);
         brreanum(thefile,theline,mapbeg);
         brreanum(thefile,theline,mapend);
      end
end;
(* end module book.brchrkey version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.getocp *)
procedure getocp(var thefile: text; var theline: integer;
                 var org: orgkey;   var orgchange, orgopen: boolean;
                 var chr: chrkey;   var chrchange, chropen: boolean;
                 var pie: pieceptr; var piechange, pieopen: boolean);
(* Get the next piece and its organism and chromosome keys.  The three change
variables indicate whether or not a new organism, chromosome or piece name
was found.  If a piece is not found, then pieopen will be false.  orgopen,
chropen and pieopen are used by getocp to tell when it has entered an
organism, chromosome or piece.  All booleans should be set to false
initially.  There should be one triplet for each book read.

It is important to initialize ALL variables, including pie:

   orgchange := false; orgopen := false;
   chrchange := false; chropen := false;
   piechange := false; pieopen := false;
   pie := nil;
   theline := 0;

1999 June 2  The book reading routines now treat data objects more
precisely.  Rather than test for eof, the endo of book occurs when pieopen is
returned as false.  A book reading loop now looks like this:

   repeat
      getocp(book, theline,
                   org, orgchange, orgopen,
                   chr, chrchange, chropen,
                   pie, piechange, pieopen);
      writeln(output,'pieopen: ',pieopen);
      if pieopen then begin
         writeln(output,'piece at line: ',theline:1);
      end;
   until not pieopen;
*)

var
      ch: char;
      newchr: chrkey;
      neworg: orgkey;
      newpie: pieceptr;
begin
      ch:='a';
      while not (ch in [' ','p']) do begin
         ch:=getto(thefile,theline,['o','c','p']);
         if ch <> ' ' then begin
            case ch of
               'o': if orgopen
                  then begin
                     readln(thefile);
                     (* move past the word 'organism'
                        - new definition 1999 Mar 13 *)
                     orgopen:=false (* close organism *)
                  end
                  else begin
                     brorgkey(thefile,theline,neworg);
                     if (neworg.hea.keynam.letters <> org.hea.keynam.letters) and
                        (neworg.hea.keynam.length <> org.hea.keynam.length)
                     then begin
{
writeln(output,'--------orgchanged!');
write  (output,'--------old org:"',   org.hea.keynam.letters);
writeln(output,              '" ',    org.hea.keynam.length:1);
write  (output,'--------new org:"',neworg.hea.keynam.letters);
writeln(output,              '" ',neworg.hea.keynam.length:1);
}
(*ccc*)
                        orgchange:=true;
                        copyheader(neworg.hea,org.hea);
                        (* move the mapunit over to the org! *)
                        org.mapunit := neworg.mapunit;
                        clearline(neworg.mapunit);

                     end
                     else orgchange:=false;
                     orgopen:=true;
                  end;
               'c': if chropen
                  then begin
                     readln(thefile);
                     (* move past the word 'chromosome'
                        - new definition 1999 Mar 13 *)
                     chropen:=false (* close chromosome *)
                  end
                  else begin
                     brchrkey(thefile,theline,newchr);
                     if (newchr.hea.keynam.letters <> chr.hea.keynam.letters) and
                        (newchr.hea.keynam.length <> chr.hea.keynam.length)
                     then begin
{
writeln(output,'--------chrchanged!');
write  (output,'--------old chr:"',   chr.hea.keynam.letters);
writeln(output,              '" ',    chr.hea.keynam.length:1);
write  (output,'--------new chr:"',newchr.hea.keynam.letters);
writeln(output,              '" ',newchr.hea.keynam.length:1);
}
                        chrchange:=true;
                        copyheader(newchr.hea,chr.hea);
                        (* move the map range over to the chr! *)
                        chr.mapbeg := newchr.mapbeg;
                        chr.mapend := newchr.mapend;
                     end
                     else chrchange:=false;
                     chropen:=true;
                  end;
               'p': if pieopen
                  then begin
                     pieopen:=false; (* close last piece *)
                     ch:='a' (* prevent falling out of the loop *)
                  end
                  else begin
                     new(newpie);
                     brpiece(thefile,theline,newpie);
                     if pie = nil
                     then piechange := true
                     else begin
                        if (newpie^.key.hea.keynam.letters
                         <> pie^.key.hea.keynam.letters) and
                           (newpie^.key.hea.keynam.length
                         <> pie^.key.hea.keynam.length)
                        then begin
                           piechange:=true;
                        end
                        else piechange:=false;
                     end;
                     pieopen:=true;
                     (* we always have to switch over to the new piece,
                        because although the name may be the same,
                        the DNA sequence could be different.  That is,
                        the book may contain two pieces with the same
                        name, and we want to be sure to search the
                        new one, not the old one. *)
                     if pie <> nil then begin
                        clearpiece(pie); (* save the links *)
                        dispose(pie); (* close up shop *)
                     end;
                     pie := newpie;
                  end
            end
         end
         else begin
            pieopen := false
         end
      end
end;
(* origin: search version = 6.39 *)
(* end module book.getocp version = 7.62; {of delmod.p 2003 Jan 13} *)

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

(* begin module book.bwbasics *)

procedure bwstartline(var book: text);
(* start a line of output to the book *)
begin
      write(book,'* ')
end;

procedure bwline(var book: text; l: lineptr);
(* write a line to the book *)
var   i: integer;
begin
   if l<>nil then begin
      bwstartline(book);
      if l^.length<>0
      then for i:=1 to l^.length do write(book,l^.letters[i]);
      writeln(book);
   end
end;

procedure bwtext(var book: text; lines: lineptr);
(* write a set of lines to the book *)
var 
   l: lineptr;   
begin 
   l := lines; 
   while l<>nil do begin
      bwline(book,l);
      l := l^.next; 
   end; 
end;

procedure bwnote(var book: text; note: lineptr);
(* writes the notes pointed to by 'note' to 'book' *)
begin
   if note<>nil then begin
      writeln(book,'note');
      bwtext(book,note);
      writeln(book,'note');
   end
end;

procedure bwnumber(var book: text; num: integer);
(* write a number to the book *)
begin
   bwstartline(book);
   writeln(book,num:1) (* pascal will expand the field as far as needed *)
end;

procedure bwreanum(var book: text; reanum: real);
(* write a real number to the book *)
begin
   bwstartline(book);
   writeln(book,reanum:1:2) (* pascal will expand the field *)
end;

procedure bwstate(var book: text; sta: state);
(* write a state to the book *)
begin
   bwstartline(book);
   case sta of
      on:  writeln(book,'on');
      off: writeln(book,'off')
   end
end;

procedure bwname(var book: text; nam: name);
(* write a name to the book *)
var   i: integer;
begin
   with nam do begin
      bwstartline(book);
      for i:=1 to length do write(book,letters[i]);
      writeln(book)
   end
end;

procedure bwdirect(var book: text; direct: direction);
(* write a direction to the book *)
begin
   bwstartline(book);
   case direct of
      plus:  writeln(book,'+');
      minus: writeln(book,'-')
   end
end;

procedure bwconfig(var book: text; config: configuration);
(* write a configuration to the book *)
begin
   bwstartline(book);
   case config of
      linear:   writeln(book,'linear');
      circular: writeln(book,'circular')
   end
end;

procedure bwheader(var book: text; hea: header);
(* write a key header to the book *)
begin
   with hea do begin
      bwname(book,keynam);
      bwline(book,fulnam);
      bwnote(book,note);
   end
end;
 
procedure bworgkey(var book: text; org: orgkey);
(* write the organism key *)
begin
   with org do begin
      bwheader(book,hea);
      bwline  (book,mapunit)
   end
end;
 
procedure bwchrkey(var book: text; chr: chrkey);
(* write the chromosome key *)
begin
   with chr do begin
      bwheader(book,hea);
      bwreanum(book,mapbeg);
      bwreanum(book,mapend)
   end
end;

(* end module book.bwbasics version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.bworg *)
procedure bworg(var thefile: text; org: orgkey;
                var chropen, orgopen: boolean);
(* this writes the organism key 'org' to 'thefile', and returns 'orgopen'
   as true.  if there is already a chromosome or organism open they
   are closed. *)
begin
      if chropen then begin
         writeln(thefile,'chromosome');
         chropen := false;
      end;
      if orgopen then writeln(thefile,'organism');
      writeln(thefile,'organism');
      bworgkey(thefile,org);
      orgopen := true;
end;
(* end module book.bworg version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.bwchr *)
procedure bwchr(var thefile: text; chr: chrkey; var chropen: boolean);
(* write the chromosome key 'chr' to 'thefile' and return chropen as
   true.  if a chromosome is already open it is closed. *)
begin
      if chropen then writeln(thefile,'chromosome');
      writeln(thefile,'chromosome');
      bwchrkey(thefile,chr);
      chropen := true;
end;
(* end module book.bwchr version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.bwdna *)
procedure bwdna(var thefile: text; d: dnaptr);
(* write the dna pointed to by 'd' to 'thefile' *)
var i: integer; (* index to the sequence *)
    l: integer; (* index to the number of bases on the line *)
    newline: boolean; (* true when a new line should be started *)
begin
   writeln(thefile,'dna');
   newline := true;
   while (d <> nil) do begin
      for i := 1 to d^.length do begin
         if newline then begin
            bwstartline(thefile);
            l := 0;
            newline := false
         end;
         write(thefile,basetochar(d^.part[i]));
         l := succ(l);
         if (l mod 60 = 0) or  (* end of line *)
            ((i = d^.length) and (d^.next = nil)) (* last base *)
         then begin
            writeln(thefile);
            newline := true
         end;
      end;
      d := d^.next;
   end;
   if not newline then writeln(thefile); (* last base *)
   writeln(thefile,'dna');
end;  
(* end module book.bwdna version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.bwpie *)
procedure bwpie(var thefile: text; pie: pieceptr);
(* writes the information pointed to by 'pie' to 'thefile' *)
begin
   writeln(thefile,'piece');
   with pie^ do begin
      bwheader(thefile,key.hea);

      bwstartline(thefile);
      writeln(thefile,key.mapbeg:1:2);

      bwstartline(thefile);
      if (key.coocon = circular) then writeln(thefile,'circular')
            else writeln(thefile,'linear');

      bwstartline(thefile);
      if (key.coodir = plus) then writeln(thefile,'+')
            else writeln(thefile,'-');

      bwstartline(thefile);
      writeln(thefile,key.coobeg:1);

      bwstartline(thefile);
      writeln(thefile,key.cooend:1);

      bwstartline(thefile);
      if (key.piecon = circular) then writeln(thefile,'circular')
            else writeln(thefile,'linear');

      bwstartline(thefile);
      if (key.piedir = plus) then writeln(thefile,'+')
            else writeln(thefile,'-');

      bwstartline(thefile);
      writeln(thefile,key.piebeg:1);

      bwstartline(thefile);
      writeln(thefile,key.pieend:1);
   end;
   bwdna(thefile,pie^.dna);
   writeln(thefile,'piece');
end;
(* end module book.bwpie version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.bwref *)
procedure bwref(var book: text; ref: reference);
(* write a key reference to the book *)
begin
   with ref do begin
      bwname  (book,pienam);
      bwreanum(book,mapbeg);
      bwdirect(book,refdir);
      bwnumber(book,refbeg);
      bwnumber(book,refend)
   end
end;
(* end module book.bwref version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.bwgen *)
procedure bwgen(var thefile: text; gene: genkey);
(* this proecdure writes to 'thefile' the information in 'gene',
   properly formatted; *)
begin
      writeln(thefile,'gene');
      with gene do
      begin
         bwheader(thefile,hea);
         bwref(thefile,ref);
      end;
      writeln(thefile,'gene');
end;
(* end module book.bwgen version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.bwtra *)
procedure bwtra(var thefile: text; trans: trakey);
(* this proecdure writes to 'thefile' the information in 'trans',
   properly formatted; *)
begin
      writeln(thefile,'transcript');
      with trans do
      begin
         bwheader(thefile,hea);
         bwref(thefile,ref);
      end;
      writeln(thefile,'transcript');
end;
(* end module book.bwtra version = 7.62; {of delmod.p 2003 Jan 13} *)

(* begin module book.bwmar *)
procedure bwmar(var thefile: text; mark: marker);
(* this proecdure writes to 'thefile' the information in 'mark',
   properly formatted; *)
var i : integer;
begin
      writeln(thefile,'marker');
      with mark.key do
      begin
         bwheader(thefile,hea);
         bwref(thefile,ref);
         bwstate(thefile,sta);
         bwstartline(thefile);
         for i := 1 to phenotype^.length do
            write(thefile,phenotype^.letters[i]);
         writeln(thefile);
      end;
      bwdna(thefile,mark.dna);
      writeln(thefile,'marker');
end;
(* end module book.bwmar version = 7.62; {of delmod.p 2003 Jan 13} *)

(****************************************************************************)
(* end module package.bwrite version = 7.62; {of delmod.p 2003 Jan 13} *)

{qqq}

(* begin module align.write *)
{aaa}
procedure alignwrite(var inst, book: text; var theline: integer;
                var length, alignedbase: integer;
                var org: orgkey;   var orgchange: boolean;
                                   var orgopen:   boolean;
                var chr: chrkey;   var chrchange: boolean;
                                   var chropen:   boolean;
                var pie: pieceptr; var piechange: boolean;
                                   var pieopen:   boolean);
(* documentation on align is in module info.align and
delman.use.aligned.books.
1996 Sep 12: The routine now uses the trigger functions found
in prgmod.  The bug in the oldalign routine (that it misses the
end of comments that end in a series of astrisks) has been fixed.
It now checks that the piece corresponds to the book. *)
const maximumrange = 10000; (* if the alignment point is more than this
   distance from the piece ends, the program halts in an attempt to catch
   the alignment bug... 1991 Jan 11 It appears that the rewrite of the
   code has removed the bug, but the check will be kept. *)
   semicolon = ';'; (* end of delila instruction *)
var
   ch: char; (* a character in inst *)
   p: integer; (* index to a piece name *)
   p1: integer; (* another index to a piece name *)
   done: boolean; (* done finding an aligning get *)
   thebase: integer; (* the base read in *)
   indefault: boolean; (* true when within a default statement.  These
      can contain the word 'piece', which must be ignored. *)

   gettrigger: trigger; (* trigger to find 'get' *)
   defaulttrigger: trigger; (* trigger to find 'default' *)
   nametrigger: trigger; (* trigger to find 'name' *)
   piecetrigger: trigger; (* trigger to find 'piece' *)
   settrigger: trigger; (* trigger to find 'set' *)

   begincomment: trigger; (* trigger to find '(-*' (ignore the dash!) *)
   endcomment: trigger; (* trigger to find '*-)'  (ignore the dash!) *)
   begincurly: trigger; (* trigger to find comments: '{' *)
   endcurly: trigger; (* trigger to find comments: '}' *)

   quote1trigger: trigger; (* trigger to find single quote ' *)
   quote2trigger: trigger; (* trigger to find double quote " *)

{
procedure rd(var f: text; var ch: char);
(* read ch from f allowing inspection of the result *)
begin
   read(f,ch);
   write(output,ch);
   write(list,ch);
   write(output,'<',ch,'>');
end;

procedure rdln(var f: text);
(* readln f allowing inspection of the result *)
begin
   readln(f);
   writeln(output);
   writeln(list);
end;
}

procedure skipcomment(var f: text);
(* skip an entire comment *)
var
   comment: boolean; (* true means we are inside a comment *)
begin
   (* skip to end of comment *)
   resettrigger(endcomment);
   comment := true;
   while comment do begin
      if eof(f) then begin
         writeln(output,'A comment does not end!');
         halt
      end;
      if eoln(f) 
      then readln(f)
{ rdln(f) }
      else begin
{write(output,'<');
rd(f,ch);
write(output,'>');}
         read(f,ch);
         testfortrigger(ch, endcomment);
         if endcomment.found
         then comment := false;
      end
   end
end;

procedure skipcurly(var f: text);
(* skip an entire comment made by {}*)
var
   comment: boolean; (* true means we are inside a comment *)
begin
   (* skip to end of comment *)
   resettrigger(endcurly);
   comment := true;
   while comment do begin
      if eof(f) then begin
         writeln(output,'A comment does not end!');
         halt
      end;
      if eoln(f) 
      then readln(f)
{ rdln(f) }
      else begin
{write(output,'<');
rd(f,ch);
write(output,'>');}
         read(f,ch);
         testfortrigger(ch, endcurly);
         if endcurly.found
         then comment := false;
      end
   end
end;

procedure skipquote(quote: trigger);
(* skip an entire quote of either the ' or " persuasion *)
var
   kind: char; (* the kind of quote, ' or " *)
begin
   kind := quote.seek.letters[1];
{writeln(output,'skipquote ',kind);}
   repeat
      findnonblank(inst,ch); (* get to the quote *)
   until (ch = kind) or eof(inst);
   if ch <> kind then begin
      writeln(output,'end of quote starting with ',kind,' not found');
      halt;
   end;
end;

begin
 filltrigger(defaulttrigger,'default');
     filltrigger(gettrigger,'get    ');
    filltrigger(nametrigger,'name   ');
   filltrigger(piecetrigger,'piece  ');
     filltrigger(settrigger,'set    ');
   filltrigger(begincomment,'(*     ');
     filltrigger(endcomment,'*)     ');
     filltrigger(begincurly,'{      ');
       filltrigger(endcurly,'}      ');
  filltrigger(quote1trigger,'''      ');
  filltrigger(quote2trigger,'"      ');

  resettrigger(defaulttrigger);
  resettrigger(gettrigger);
  resettrigger(nametrigger);
  resettrigger(piecetrigger);
  resettrigger(settrigger);

  resettrigger(begincomment);
  resettrigger(begincurly);
  resettrigger(quote1trigger);
  resettrigger(quote2trigger);

   indefault := false;

   if not eof(book) then begin (* if there is still more to the book ... *)
   writeln(output, 'before getocp line ', theline:1);
      getocp(book, theline,
                   org, orgchange, orgopen,
                   chr, chrchange, chropen,
                   pie, piechange, pieopen);
   writeln(output, 'after getocp line ', theline:1);
{
      getpiece(book,theline,pie); (* read in the piece *)
}

if orgopen then begin
   writeln(output, 'orgopen at line ', theline:1);
end
else begin
   writeln(output, 'NO orgopen at line ', theline:1);
end;
if chropen then begin
   writeln(output, 'chropen at line ', theline:1);
end
else begin
   writeln(output, 'NO chropen at line ', theline:1);
end;
if orgchange then begin
   writeln(output, 'orgchange at line ', theline:1);
end
else begin
   writeln(output, 'NO orgchange at line ', theline:1);
end;
if chrchange then begin
   writeln(output, 'chrchange at line ', theline:1);
end
else begin
   writeln(output, 'NO chrchange at line ', theline:1);
end;

if orgchange then begin
   writeln(output, 'WRITE ORG');
   bworg(output, org, chropen{OUT}, orgopen{OUT});
{hhh}
   bworg(bookout, org, chropen, orgopen);
   writeln(output, 'WRITE ORG DONE');
halt;
end;

if chrchange then begin
   writeln(output, 'WRITE CHR');
{
   bwchr(output, chr, chropen);
}
   chropen := false;
   bwchr(bookout, chr, chropen{OUT});
   writeln(output, 'WRITE CHR DONE');
end;


      if not eof(book) then begin (* if we found a piece ... *)
         length:=pietoint(pie^.key.pieend,pie); (* calculate piece length *)

         (* now find in inst the next occurance of 'get' *)
         done := false;
         while not done do begin
            if eof(inst) then begin (* no instructions? *)
               alignedbase := 1; (* simply align by the first base *)
               done := true
            end
            else begin
               if eoln(inst)
               then readln(inst)
{then rdln(inst)}
               else begin
{rd(inst,ch);}
                  read(inst,ch);

                  testfortrigger(ch, begincomment);
                  testfortrigger(ch, begincurly);
                  if begincomment.found or begincurly.found
                  then begin
                     if ch = '*' then begin
                        skipcomment(inst);
                        resettrigger(begincomment);
                     end
                     else begin
                        resettrigger(begincurly);
                        skipcurly(inst);
                     end
                  end
                  else begin (* we are not inside a comment *)

                     testfortrigger(ch, gettrigger);
                     if gettrigger.found then begin
                        findnonblank(inst,ch); (* get to "from" *)
                        findblank(inst); (* get past "from" *)
                        read(inst,thebase); (* read in the alignedbase *)
{writeln(output);writeln(output,'thebase = ',thebase:1);}
                        alignedbase:=pietoint(thebase,pie);
{writeln(output,'alignedbase=',alignedbase:1);}
                        done := true
                     end;

                     testfortrigger(ch, quote1trigger);
                     if quote1trigger.found then begin
                        skipquote(quote1trigger);
                     end;

                     testfortrigger(ch, quote2trigger);
                     if quote2trigger.found then begin
                        skipquote(quote2trigger);
                     end;

                     testfortrigger(ch, defaulttrigger);
                     if defaulttrigger.found then begin
                        indefault := true;
                        resettrigger(defaulttrigger)
                     end;
                     if ch = semicolon then indefault := false;

                     testfortrigger(ch, settrigger);
                     if settrigger.found then begin
                        indefault := true;
                        resettrigger(settrigger)
                     end;
                     if ch = semicolon then indefault := false;

                     (* check that piece names are correct *)
                     testfortrigger(ch, piecetrigger);
                     if not indefault then if piecetrigger.found then begin
                        skipblanks(inst); (* get to name *)
                        with pie^.key.hea.keynam do begin
                           for p := 1 to length do begin
                              read(inst,ch);
                              if letters[p] <> ch then begin
                                 writeln(output,'The piece name in the book: ');
                                 writeln(output,letters:length);
                                 writeln(output,'does not match',
                                              ' the inst file name:');
                                 (* write the letters that matched: *)
                                 for p1 := 1 to p-1 do write(output,letters[p]);
                                 (* write the offending letter: *)
                                 write(output, ch);
                                 (* get the rest of the name and show it: *)
                                 done := eoln(inst);
                                 while not done do begin
                                   done := eoln(inst);
                                   if not done then begin
                                     read(inst,ch);
                                     if (ch = ' ') or (ch = ';') then done := true;
                                     if not done then write(output,ch);
                                   end;
                                 end;
                                 writeln(output);
                                 (* mark the first letter that does not match: *)
                                 for p1 := 1 to p-1 do write(output,' ');
                                 write(output,'^');
                                 writeln(output);
                                 halt
                              end;
                           end
                        end;
                     end;

                  end
               end
            end
         end;

         if (alignedbase <= -maximumrange) or
            (alignedbase > length + maximumrange) then begin
            writeln(output,' In procedure align:');
            writeln(output,' read in base was ',thebase:1);
            writeln(output,' in internal coordinates: ',alignedbase:1);
            writeln(output,' maximum range was ',maximumrange:1);
            writeln(output,' piece length was ',length:1);
            with pie^.key.hea.keynam
               do writeln(output,' piece name: ',letters:length);
            writeln(output,' piece number: ',number:1);
            writeln(output,' aligned base is too far away... see the code');
            halt
         end
      end
   end
end;
(* end module align.write *)

(* begin module MODIFIEDalign.maxminalignment *)
(* MODIFIED -  delete later *)
procedure maxminalignment(var inst, book: text; var theline: integer;
                          var fromparam, toparam: integer;
                          alignmenttype: char);
(* prescan the book to find the range over which the pieces of the
   book are spread, relative to the aligned base.  the procedure uses
   the same variables that align does (so it can call align itself), and
   it returns the range in fromparam and toparam.
   alignmenttype: 'f' means alignment by First internal coordinate
      base, 'b' means alignment by Book, 'i' means alignment by Instructions.
 *)
const
      maximumrange = 500; (* the maximum size aligned piece;
                             this will presumably catch the alignment bug *)
var
      distance: integer; (* a distance to the aligned base *)
      pie:  pieceptr;
      length, alignedbase: integer;
begin
      new(pie);
      (* set an initial range for the two bounds *)
      fromparam:=+maxint;
        toparam:=-maxint;

      reset(book);
      reset(inst);
      while not eof(book) do begin
         case alignmenttype of
            'i':
;
{
alignwrite(inst,book,theline,pie,length,alignedbase);
}
            'b','f':  begin
                 getpiece(book,theline,pie); (* read in the piece *)
                 length := piecelength(pie);
            end;
         end;

         if not eof(book) then begin
            case alignmenttype of
               'f': begin (* force alignment on first base *)
                    alignedbase := 0;
                    fromparam := 1;
                    distance:=length-alignedbase;
                    if toparam < distance then toparam:=distance;
               end;
               'i': begin (* use the alignedbase from the book *)
                    distance:=1-alignedbase;
                    if fromparam > distance then fromparam:=distance;

                    distance:=length-alignedbase;
                    if toparam < distance then toparam:=distance;
               end;
               'b': begin (* use the internal book *)
                    alignedbase := pietoint(0, pie);
                    distance:=1-alignedbase;
                    if fromparam > distance then fromparam:=distance;

                    distance:=length-alignedbase;
                    if toparam < distance then toparam:=distance;
               end;
            end;

            clearpiece(pie)
         end
      end;

      if toparam - fromparam > maximumrange then begin
         writeln(output,' in procedure maxminalignment:');
         writeln(output,' alignedbase = ',alignedbase:1);
         writeln(output,' fromparameter = ',fromparam:1);
         writeln(output,' toparameter = ',toparam:1);
         writeln(output,' this exceeds the maximum range allowed (',
                        maximumrange:1,')');
         writeln(output,' see notes in the procedure. ');
         halt
         (* notes:  if you desired this range, increase 'maximumrange'.
            otherwise, this may indicate a bug - either:
            1) locate the bug (and tell tom schneider, please...)
            2) reduce the size of the fragments, from one or the other end
               until the bombing is stopped. *)
      end;

      (* make the book readable again *)
      reset(book);
      reset(inst);
      dispose(pie)
end;
(* end module MODIFIEDalign.maxminalignment *)
(* version = 7.60; {of delmod.p 2003 May  3} *)

(* 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} *)

{
uuu
uuu
}

(* begin module align.realignbook *)
procedure realignbook(var inst, book, bookout: text;
                          var fromparam, toparam: integer;
                          alignmenttype: char);
(* realign the book according to the inst.
   alignmenttype: 'f' means alignment by First internal coordinate
      base, 'b' means alignment by Book, 'i' means alignment by Instructions.
*)

const
   maximumrange = 500; (* the maximum size aligned piece;
                             this will presumably catch the alignment bug *)
var
   distance: integer; (* a distance to the aligned base *)
{
   pie:  pieceptr;
}
   length, alignedbase: integer;
   theline: integer; (* current line in the book *)

   org: orgkey;   orgchange, orgopen: boolean;
   chr: chrkey;   chrchange, chropen: boolean;
   pie: pieceptr; piechange, pieopen: boolean;

begin
   new(pie);
   (* set an initial range for the two bounds *)
   fromparam:=+maxint;
     toparam:=-maxint;


   orgchange := false; orgopen := false;
   chrchange := false; chropen := false;
   piechange := false; pieopen := false;
{
   pie := nil;
}
   new(pie);
   theline := 0;

   reset(book);
   reset(inst);
   rewrite(bookout);

   copyaline(book, bookout); (* copy the title over *)
   theline := 1;

{
      while not eof(book) do begin
}
   repeat

{
      getocp(book, theline,
                   org, orgchange, orgopen,
                   chr, chrchange, chropen,
                   pie, piechange, pieopen);
      writeln(output,'pieopen: ',pieopen);
      if pieopen then begin
         writeln(output,'piece at line: ',theline:1);
      end;
}

(* the problem is that the align routine is designed
only to READ the book, not to copy the org chr and pie.
So I really need to replace align ... and that requires
reading through the inst file.
*)
writeln(output,'HERE GOES!!!!!!!');
      case alignmenttype of
         'i': alignwrite(inst,book,theline,
               {pie,} length,alignedbase,
                    org, orgchange, orgopen,
                    chr, chrchange, chropen,
                    pie, piechange, pieopen);
          'b','f':  begin
               getpiece(book,theline,pie); (* read in the piece *)
 {use getocp? }
               length := piecelength(pie);
          end;
       end;
       if eof (book) then pieopen := false;
writeln(output,'DONE ***************');

{
 halt;
      if not eof(book) then begin
}
      if pieopen then begin
         case alignmenttype of
            'f': begin (* force alignment on first base *)
                 alignedbase := 1;
                 fromparam := 1;
                 distance:=length-alignedbase;
                 if toparam < distance then toparam:=distance;
            end;
            'i': begin (* use the alignedbase from the book *)
                 distance:=1-alignedbase;
                 if fromparam > distance then fromparam:=distance;

                 distance:=length-alignedbase;
                 if toparam < distance then toparam:=distance;
            end;
            'b': begin (* use the internal book *)
                 alignedbase := pietoint(0, pie);
                 distance:=1-alignedbase;
                 if fromparam > distance then fromparam:=distance;

                 distance:=length-alignedbase;
                 if toparam < distance then toparam:=distance;
            end;
         end;

{yyy}
         bwpie(output, pie);
         bwpie(bookout, pie);
         clearpiece(pie);

halt;
      end;

   until not pieopen;
{
      end;
}

      if toparam - fromparam > maximumrange then begin
         writeln(output,' in procedure realignbook:');
         writeln(output,' alignedbase = ',alignedbase:1);
         writeln(output,' fromparameter = ',fromparam:1);
         writeln(output,' toparameter = ',toparam:1);
         writeln(output,' this exceeds the maximum range allowed (',
                        maximumrange:1,')');
         writeln(output,' see notes in the procedure. ');
         halt
         (* notes:  if you desired this range, increase 'maximumrange'.
            otherwise, this may indicate a bug - either:
            1) locate the bug (and tell tom schneider, please...)
            2) reduce the size of the fragments, from one or the other end
               until the bombing is stopped. *)
      end;

      (* make the book readable again *)
      reset(book);
      reset(inst);
      dispose(pie)
end;
(* end module align.realignbook *)


(* begin module bookshift.themain *)
procedure themain(var book, inst, bookshiftp, bookout: text);
(* the main procedure of the program *)
const
   debug = false; (* give debug output *)
var
   parameterversion: real; (* parameter version number *)

   (* variables used by the align routines: *)
   apiece: pieceptr;
{
   length, alignedbase: integer;
   fromparam, toparam: integer;
}

   alignmenttype: char; (* 'f' means alignment by First internal coordinate
      base, 'b' means alignment by Book, 'i' means alignment by Instructions *)

   gettrigger: trigger; (* trigger to locate the word 'get' in a file *)
   ch: char; (* a character from the inst file *)
   theline: integer; (* current line in the book *)
   done: boolean; (* done looking for a 'get' in the inst file *)
   zerobase: integer; (* the zero base: 'get from [zerobase]' *)
   ORIGINALpiebeg, ORIGINALpieend: integer; (* original coordinates *)

procedure notbetween;
(* report a serious problem: the zero base is not where it should be,
between the piece ends *)
begin
   with apiece^.key do begin
      writeln(output,' zero base is not between piece ends!');
      writeln(output,'   pieend: ',pieend:1);
      writeln(output,' zerobase: ',zerobase:1);
      writeln(output,'   piebeg: ',piebeg:1);
      writeln(output,'piece: ');
      bwpie(output,apiece);
      halt;
   end;
end;

begin
   writeln(output,'bookshift ',version:4:2);
   reset(bookshiftp);
   readln(bookshiftp, parameterversion);
   if round(100*parameterversion) < round(100*updateversion) then begin
      writeln(output, 'You have an old parameter file!');
      halt
   end;

   new(apiece);

   alignmenttype := 'i';
   if not eof(bookshiftp) then begin
      if not eof(bookshiftp) then begin
         readln(bookshiftp,alignmenttype);
         if not (alignmenttype in ['f','i','b']) then begin
            writeln(output,'alignment type must be f, b, or i');
            writeln(output,'alignmenttype was "', alignmenttype,'"');
            halt
         end;
      end;
   end;

   reset(inst);
   if eof(inst) then if alignmenttype = 'i' then begin
      writeln(output,'forcing alignment to be on book',
                     ' because there are no instructions');
      alignmenttype := 'b'
   end;

{
original stuff from range.p
   maxminalignment(inst,book,fromparam,toparam,alignmenttype);
   writeln(output, 'alignmenttype = ',alignmenttype);
   writeln(output, fromparam:1, ' ',toparam:1);
   writeln(bookout, fromparam:1, ' ',toparam:1);
   writeln(bookout, fromparam:1);
   writeln(bookout, toparam:1);
}

   rewrite(bookout);

{ this is based on alignbook, which is based on getocp.
getocp is built to read, not to write.
   realignbook(inst,book,bookout,fromparam,toparam,alignmenttype);
}

  filltrigger(gettrigger,'get from ');
  resettrigger(gettrigger);
  theline := 1;

  reset(book);
  reset(inst);
  while not eof(book) do begin
     (* this write statement can be used to check the output:
        write(bookout, theline:3,' ');
     *)
     if book^ = 'p' then begin
{
        write(bookout, 'PIECE ');
        copyaline(book, bookout);
}
        if debug then writeln(output, 'Piece at line ', theline:1);
        brpiece(book, theline, apiece);

        (* Read through the inst file to locate the next get.
           The mechanism here is overly sinmple and should
           be replaced with the comment and quote skipping
           mechanism in the align routines. *)

        done := false;
        while not done do begin
           if eof(inst) then begin
              write  (output,'ERROR: No get found for this piece ');
              writeln(output,' at line ',theline:1,' of the book:');
              bwpie(output, apiece);
              halt;
           end;
           if eoln(inst)
           then begin
              readln(inst);
{
              writeln(output);
}
           end
           else begin
              read(inst, ch);
{
              write(output, ch);
}
              testfortrigger(ch, gettrigger);
              if gettrigger.found
              then begin with apiece^.key do begin
                 read(inst, zerobase);
                 if debug then begin
                    writeln(output, '  zero base: ',zerobase:1);
                    writeln(output, '  from: ',piebeg:1);
                    writeln(output, '    to: ',pieend:1);
                 end;

                 ORIGINALpiebeg := piebeg;
                 ORIGINALpieend := pieend;

                 if zerobase >= piebeg then begin
                    if zerobase > pieend then begin
                       notbetween;
                    end;
                    piebeg := ORIGINALpiebeg - zerobase;
                    pieend := ORIGINALpieend - zerobase;
                 end
                 else begin {zerobase < piebeg}
                    if zerobase < pieend then begin
                       notbetween;
                    end;
                    piebeg := ORIGINALpieend - zerobase;
                    pieend := ORIGINALpiebeg - zerobase;
                 end;

                 (* force a nice coordinate system: *)
                 piedir := plus;
                 coodir := plus;
                 coobeg := piebeg;
                 cooend := pieend;

                 readln(inst);
                 resettrigger(gettrigger);
                 done := true;
              end end
           end
        end;

        bwpie(bookout, apiece);
     end
     else begin
        copyaline(book, bookout);
        theline := theline + 1;
     end;
  end;

end;
(* end module bookshift.themain *)

begin
   themain(book, inst, bookshiftp, bookout);
1: end.