program prgmod(input,
list, {ddd}
output);
(* prgmod: programming modules for the delila system

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

http://www.uwasa.fi/~ts/http/quote.html
http://en.wikipedia.org/wiki/Top-posting

*)

label 1; (* end of program *)

const
(* begin module version *)
   version = 5.85; (* of prgmod.p 2022 Dec 08
2022 Dec 08, 5.85: try feature carrier keep: boolean
2022 Dec 07, 5.84: protect write a definition
2022 Dec 07, 5.83: clean up
2022 Dec 06, 5.82: read comments
2022 Dec 06, 5.81: record feature comments ('*') in features
2022 Dec 02, 5.80: feature carrier coo and Ri
2022 Dec 02, 5.79: work on modules for best
2022 Dec 02, 5.78: using modules
2022 Dec 02, 5.77: finding total Ri
2022 Dec 02, 5.76: clean
2022 Dec 02, 5.75: set firstfeatureofgroup logic
2022 Dec 01, 5.74: group counts in features
2022 Nov 29, 5.73: working on modules for best.p
2022 Nov 29, 5.72: test in lister (it worked fine)
2022 Nov 25, 5.71: work on featureisfirstingroup identification in group
2022 Nov 25, 5.70: add number of each feature to showfeatures
2022 Nov 25, 5.69: put groupnumber into features
2022 Nov 25, 5.68: upgrade groupnumber for feature code
2017 Sep 29, 5.67: remove lister specific code.
2017 Jul 31, 5.66: add '_Schneider' to PatentMessage
2017 Mar 15, 5.65: remove censor mechanism
2017 Feb 14, 5.64: number => featurenumber or definitionnumber
2017 Feb 14, 5.63: new insertions from lister.p 
2017 Feb 14, 5.62: clean up for insertions from lister.p 
2017 Feb 14, 5.61: remove IsGapOrIsTotal module; test in multiscan
2017 Feb 14, 5.60: replace modules from multiscan:
                   multiscan.p has newer modules:
                   writeafeature
                   definition.feature.type which contains relcoo
                   remove group definition
2017 Feb 13, 5.59: clear globaldebug
2017 Jan 31, 5.58: trim down PatentMessage
2017 Jan 30, 5.57: edit PatentMessage
2017 Jan 30, 5.56: modify PatentMessage for release
{TDec 04 lll.}
2016 Aug 04, 5.55: define groups for multiple part features
2016 Jul 20, 5.54: fix filltrigger name
2016 Mar 16, 5.53: fix readadefinition to allow "" marks string.
2013 Jun 10, 5.52: fix PatentMessage - consistent capitalization!
2013 Jun 06, 5.51: increase ribl size: minribl = -10001; maxribl = +10001;
2013 Feb 26, 5.50: teach onetoken to recognize tabs
2011 May 03, 5.49: backup
2011 May 03, 5.48: onetoken and readquotestring use emptystring, not clearstring!
2011 Mar 24, 5.47: instring function
2011 Jan 20, 5.46: between function
2010 Dec 13, 5.45: stringtointeger
2010 Dec 04, 5.44: string backwards pointers
2010 Oct 20, 5.43: new modules: skipstringblanks, stringtoreal
2010 Jan 06, 5.42: readdefinitionsandfeatures: if no features return nil pointer
2010 Jan 06, 5.41: report empty feature file more clearly
2008 Aug 06, 5.40: readafeature: read last def not first
2008 Mar 11, 5.39: handle case of no features in features file.
2007 May 15, 5.38: do one more emptyafile test
2007 May 15, 5.37: correct empty features message
2007 May 07, 5.36: readdefinitionsandfeatures protected for empty afile
2007 Apr 30, 5.35: duplicateprevious must be cleared!!
2007 Apr 02, 5.34: upgrade modules from lister:
                   definition.feature.type 
                   writeafeature
                   featureinlist
                   locatefeature
                   readdefinitionsandfeatures
2007 Apr 02, 5.33: adjust PatentMessage
2007 Mar 25, 5.32: tighten output of features/riblmatrix (less space)
2006 Oct 10, 5.31: test EqualDefLocations
2006 Oct 10, 5.30: upgrade definitions/features from lister
2006 Jun 06, 5.29: concatstring must call emptystring, not clearstring
2005 Dec 22, 5.28: upgrade petals; PageOrientation control removed.
2005 Aug 06, 5.27: PageOrientation.  This may not help much.
                   See notes in genpic.
2005 Aug 04, 5.26: introduce globaldebug to allow debugging here
2005 Aug 03, 5.25: allow empty definition in writeafeature!
2005 Aug 03, 5.24: improve writeafeature debug comments
2005 Aug 03, 5.23: locatesubfeatures: remove halt
2005 Jul 12, 5.22: protect writeafeature from nil definition
2005 May 30, 5.21: numberealstring removes leading blanks to approach thewidth
2005 May 28, 5.20: digitcounter
2005 May 26, 5.19: turn off debugging of markismulti
2005 May 26, 5.18: numberrealstring must not call clearstring;
                   invention of emptystring
2005 May 25, 5.17: show patent message at start
2005 May 23, 5.16: pwid in showadefinition to unlink from other stuff
2005 May 23, 5.15: upgrade patent message
2005 May 22, 5.14: upgrade patent message
2005 Jan 27, 5.13: rearrange comment
2005 Jan 26, 5.12: ord(tab) character in isblank
2005 Jan 19, 5.11: readadefinition upgrade - use chr(tab) character
2005 Jan 14, 5.10: upgrade readheader to handle eof gracefully
2005 Jan 14, 5.09: output patent message
2005 Jan 14, 5.08: upgrade skipblanks
2004 Aug 14, 5.07: testing
2004 Aug 14, 5.06: testing ... fixed all vertical bars work!
2004 Aug 14, 5.05: upgrade showadefinition; mother/other counts work
2004 Aug 14, 5.04: markismulti duplicate mark use checked for
2004 Aug 14, 5.03: markismulti builds structure, testing WORKS!!
2004 Aug 13, 5.02: markismulti builds structure, testing
2004 Aug 13, 5.01: markismulti builds structure, testing
2004 Aug 13, 5.00: markismulti builds structure, changelist error FIXED
2004 Aug 12, 4.99: markismulti builds structure, changelist error
2004 Aug 12, 4.98: markismulti builds structure, crosstickle logic good!
2004 Aug 12, 4.97: markismulti builds structure, crosstickle mother logic good?
2004 Aug 12, 4.96: markismulti builds structure, crosstickle other logic good
2004 Aug 12, 4.95: markismulti builds structure, remove duplicate ptrs
2004 Aug 12, 4.94: markismulti builds structure, remove duplicate ptrs
2004 Aug 12, 4.93: markismulti builds structure, work on total
2004 Aug 12, 4.92: markismulti builds structure, work on total
2004 Aug 12, 4.91: markismulti builds structure, work on total
2004 Aug 12, 4.90: markismulti builds structure, work on total
2004 Aug 12, 4.89: markismulti builds structure, work on total, partially ok
2004 Aug 12, 4.88: markismulti builds structure, gap is correct
2004 Aug 11, 4.87: more mother stuff
2004 Aug 10, 4.86: mother stuff
2004 Aug  9, 4.85: feature knows it is pointed to as part of multifeature
2004 Jul 28, 4.84: cleanup
2004 Jul 28, 4.83: continue ...
2004 Jul 28, 4.82: continue ... maybe cleanup
2004 Jul 28, 4.81: markismulti functioning: threads in features
2004 Jul 28, 4.80: markismulti is for features, not definitions!
2004 Jul 28, 4.79: features can point to other features!
2004 Jul 28, 4.78: cleanup markismulti
2004 Jul 27, 4.77: readafeature bug fixed: +/- accepted 
2004 Jul 26, 4.76: continue vertical mark setup
2004 Jul 26, 4.75: isgap, istotal, ismulti in definition
2004 Jul 26, 4.74: isgap and istotal variables in features for lister
2004 Jul 22, 4.73: write about missingmatrix halt
2004 Jul 20, 4.72: spare variable for petal
2004 Jul 20, 4.71: fully functional!
2004 Jul 20, 4.70: colorrectangle becomes petal
2004 Jul 20, 4.69: readafeature: handle eoln with params
2004 Jul 19, 4.68: Tparam read first
2004 Jul 18, 4.67: Dparam introduced
2004 Jul 18, 4.66: Aparam etc cleared
2004 Jul 17, 4.65: Aparam etc defined
2004 Jul 17, 4.64: aim: hsb controls for non-matrix features.
2004 Jul 13, 4.63: cleanup
2004 Jul 13, 4.62: walker color rectangle background is FUNCTIONAL!
2004 Jul 13, 4.61: walker color rectangle background
2004 Jul 13, 4.60: features include color rectangle background
2003 Jul 31, 4.59: skipblanks counts tab as a blank
4.58 2003 Mar 16: quicksort uses integer instead of 'position'.
4.57 2002 Sep  5: clean up
4.56 2002 Jul 22: upgrade feature definition
4.55 2002 Jun 21: correct putriblmatrix to report ranges correctly
4.54 2001 Aug 29: remove tabs
4.53 2001 May 23: reportandhalt should halt!
4.52 2001 Jan 16: increase maxstring to 2000 so lister can take search strings
4.50 2000 Nov  1: give up on dash control in waves in bases
4.49 2000 Oct 31: dash control in waves in bases
4.48 2000 Oct 30: dash control in waves in cm
4.47 2000 Oct  9: report more feature info if bad read
4.46 2000 Sep  2: allow marks to be written in any order in lister
4.44 2000 Jul 30: upgrade to GPCC
4.43 2000 Jul 18: introduce pluckdigit
4.42 2000 Jun 24: upgrade of numberbar
4.41 2000 Jun 14: readdefinitionsandfeatures: duplicate disposal bug
                   solved!
4.39 1999 Nov 28: minor comment fix in onetoken
4.38 1999 Aug 16: bug in readdefinitionsandfeatures: duplicate disposal
     just remove dispose for now.
4.37 1999 Aug 9: feature bug: in readdefinitionsandfeatures duplicate
     definitions were being deleted.  Disposing the link caused bombs for
     unknown reasons.  New method:  you may redefine features, but only
     the first one gets found.
4.35 1999 July 15: numbersize uses fixed
4.32 1999 July 14: fixed bug in numberstring (test is numberstringtest)
1999 July 5: features and definitions
1997 October 22: numberstring
1997 March 15: attachstring
1996 Aug 12: copyline
origin before 1989 Aug 28 TDS *)
(* end module version *)

(* begin module describe.prgmod *)
(*
name
      prgmod: programming modules for the delila system

synopsis
      prgmod(input: intty, output: out)

files
      input: interactive file used for testing the program
      output: messages to the user.

description
      prgmod is a set of generally useful modules for Pascal programming.
      these include procedures for interactive input/output, producing
      bars of numbers for graphs (called 'numbars') and sorting of
      arrays with a very fast algorithm.

         Successful compilation and running of the program indicates
      that the modules are correct.  the program is interactive, so
      to test the modules, follow the instructions prgmods provides.

see also
      delmod.p, module.p, alist.p (uses numbar), index.p (uses quicksort)
      prgmodp

author
      Thomas D. Schneider

bugs
      none known

technical notes
      the interactive routines may have to be changed when the program
      is transported.

*)
(* end module describe.prgmod *)

superdebug = false; (* allow special debugging mode for figuring out
                       vertical colored bars *)
globaldebug = true; (* for global debugging.  Any program
   that uses these routines can set these independently. *)

(* ************************************************************************ *)
(* ************************************************************************ *)
(* 1999 July 7: These module are wrappers that just allow the nicer names to
   be used, while still allowing old programs to work.  For example, the old
   name interact.const may now be called string.const *)

(* begin module interact.const *)
(* begin module string.const *)
(* end module string.const *)
(* end module interact.const *)

(* begin module interact.type *)
(* begin module string.type *)
(* end module string.type *)
(* end module interact.type *)

(* begin module rsgra.type *)
(* begin module wave.type *)
(* end module wave.type *)
(* end module rsgra.type *)

(* begin module interact.clearstring *)
(* begin module clearstring *)
(* end module clearstring *)
(* end module interact.clearstring *)

(* begin module interact.writestring *)
(* begin module writestring *)
(* end module writestring *)
(* end module interact.writestring *)

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

(* begin module string.const *)
      maxstring = 2000; (* the maximum string *)
(* end module string.const *)

(* begin module filler.const *)
      fillermax = 50; (* the size of the filler array for a string *)
(* end module filler.const *)

(* begin module postscript.const *)
   (* The following bounding box is for the Canon Color Laser Copier 800S. *)
   defaultllx =  10.08; (* lower left x *)
   defaultlly =   8.91; (* lower left y *)
   defaulturx = 588.06; (* upper left x *)
   defaultury = 779.85; (* upper left y *)
{
   (* The following bounding box is for the inkjet Tektronix Phaser 140. *)
   defaultllx =  14.4; (* lower left x *)
   defaultlly =  28.9; (* lower left y *)
   defaulturx = 596.8; (* upper left x *)
   defaultury = 777.7; (* upper left y *)
}
   pwid = 8; (* width in character places to print PostScript numbers *)
   pdec = 5; (* decimal places to print PostScript numbers *)
(* end module postscript.const *)

(* begin module ribl.const *)
   minribl = -10001; (* lowest  ribl matrix from allowed *)
   maxribl = +10001; (* highest ribl matrix to   allowed *)
   defnegativeinfinity = -1000; (* default for negative infinity
                                   for the Ri(b,l) table *)
(* end module ribl.const *)

(* begin module info.const *)
   infofield = 10; (* size of field for printing information in bits *)
   infodecim = 6; (* number of decimal places for printing information *)
       (* these are used for conlist only *)
   nfield = 8; (* size of field for printing n, the number of sites *)
(* end module info.const *)

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

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 *)
      previous: stringptr; (* the previous string in a series *)
      next: stringptr; (* the next string in a series *)
   end;
(* end module string.type *)

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

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

(* begin module wave.type *)
      waveptr = ^waveparam; (* to link several wave definitions together *)
      waveparam = record (* parameters to define a cosine wave *)
         (* define a cosine wave: *)
         extreme: char; (* h or l, the high or low extreme to be defined *)
         wavelocation: real; (* the location in bases of the extreme *)
         wavebit: real; (* the location in bits of the extreme *)
         waveamplitude: real; (* the amplitude of the wave in bits *)
         wavelength: real; (* the wave length of the wave in bases *)
{ 2000 Nov 1.  This is difficult because the length of a curve is not
simply multiplied by a scale factor.
         BASEdashon: real; (* dashon interval in bases *)
         BASEdashoff: real; (* dashon interval in bases *)
         BASEdashoffset: real; (* dashon interval in bases *)
}
         dashon: real; (* the size of on dashes in cm.
                          dashon <= 0 means no dashes *)
         dashoff: real; (* the size of on dashes in cm *)
         dashoffset: real; (* the size of off dashes in cm *)
         thickness: real; (* thickness of the wave in cm.  <= 0 means default *)
         next: waveptr; (* the next wave *)
      end;
(* end module wave.type version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module base.type *)
   (* define the four nucleotide bases *)
   base = (a,c,g,t);
(* end module base.type *)
 
(* begin module scan.type *)
   (* define the ribl matrix.  Source library is prgmod.p
      REQUIRES ribl.const module
      REQUIRES base.type or book.type module
      REQUIRES wave.type module for wave definition! *)
   rblarray = array[a..t, minribl..maxribl] of real; (* real(B,L) *)
   ribltype = record
      riblname: string; (* name of the weight matrix *)
      riblheader: stringptr; (* misc header information, starting with '*' *)
      data: rblarray; (* real(B,L) *)
      numbers: array[a..t, minribl..maxribl] of integer; (* n(b,l) *)
      frombase, tobase: integer; (* range of the matrix *)
      mean, stdev: real; (* mean and standard deviation of distribution *)
      consensus: real; (* Ri value of consensus sequence *)
      anticonsensus: real; (* Ri value of anticonsensus sequence *)
      averageRi: real; (* average Ri for random sequence *)
      n: integer; (* number of sequences used to create matrix *)
      symmetry: char; (* the symmetry of the Riblmatrix *)
      waves: waveptr; (* cosine wave definitions for the matrix *)
      cmperbase, cmperbit: real; (* required for wave dash definition *)
      Ribound: real; (* the Ri boundary for this definition *) 
      Zbound: real; (* the Z boundary for this definition *) 
      Pbound: real; (* the probability boundary for this definition *) 
   end;
   ribltypeptr = ^ribltype; (* pointer to ribltype so it does
      not need to be created unless actually used *)
(* end module scan.type *)

(* begin module definition.feature.type *)

   (* Features and their definitions for the lister program *)
   petaltype = record
      (* define parts of a colored rectangle around a walker *)
      el: integer; (* edgelinewidth: edge linewidth (integer) *)
      c : char;    (* color kind: how color is defined: r for RGB, h for HSB *)
      (* ---------------------------------------------- *)
      eh: real;    (* edgeh: edge hue        OR red     *)
      es: real;    (* edges: edge saturation OR blue    *)
      eb: real;    (* edgeb: edge brightness OR green   *)
      (* ---------------------------------------------- *)
      fh: real;    (* fillh: fill hue        OR red     *)
      fs: real;    (* fills: fill saturation OR blue    *)
      fb: real;    (* fillb: fill brightness OR green   *)
      (* ---------------------------------------------- *)
      spare: real;    (* spare variable *)
   end;

   commenttypeptr = ^commenttype; (* pointer to commettype *)
   commenttype = record (* store a comment *)
      name: string; (* name of the comment *)
      next: commenttypeptr; (* the next definition recorded *)
   end;

   definitiontypeptr = ^definitiontype; (* pointer to definitiontype *)
   definitiontype = record (* store a definition *)
(*
         define "Site" "-" "<v0*]" "[*0^>" -7 -3.5 0 +3.0 +5
*)
      nametag: string; (* name of the feature *)
      background: string; (* background padding characters *)
      negparts: string; (* parts of the feature display *)
      posparts: string; (* parts of the feature display *)
      locations: array [1..maxstring] of real; (* locations of the marks
         of the feature *)
      (* ---------------------------- *)
      (* computed values: *)
      marks: integer; (* the number of marks used in this feature *)
      min: real; (* one end of the feature (minimum location) *)
      max: real; (* the other end of the feature (maximum location) *)
      definitionnumber: integer; (* the number of the definition read in *)
      matrix: ribltypeptr; (* an ribl matrix if available *)
      (* The following boundaries are DIFFERENT from the originally defined
         boundaries of the matrix.  This allows the matrix to keep its bounds
         (eg for default values for scanning AND it allows the lister program
         to define separate boundaries for displaying green versus red on the
         zero bar.  *)
      RiboundFeature: real; (* the Ri boundary for this feature *)
      ZboundFeature: real; (* the Z boundary for this feature *)
      PboundFeature: real; (* the probability boundary for this feature *)
      petal: petaltype; (* color rectangle background *)
      isgap: boolean; (* the definition represents a gap between two
                         sequence walkers *)
      istotal: boolean; (* the definition represents a total feature for
                           a set of sequence walkers *)
      ismulti: boolean; (* the definition represents a sequence walker 
                           that is part of a set of sequence walkers *)
      next: definitiontypeptr; (* the next definition recorded *)
   end;

(* ---------------------------- *)
   featurecarrierptr = ^featurecarrier; (* pointer to featurecarrier *)
   featuretypeptr = ^featuretype; (* pointer to featuretype *)
   featurecarrier = record (* carries a list of features *)
      (* to make a list of features, we need a carrier that
         is not the original feature list. *)
      afeature: featuretypeptr; (* the feature being carried *)
      coo: integer; (* coordinate of total *)
      Ri: real; (* Ri of total *)
      keepgroup: boolean; (* keep this group when printing *)
      next: featurecarrierptr; (* the next carriage *)
   end;
   featuretype = record (* store a feature *)
(*
         @ K01789 270 +1 "Site" "Positive 270"
         @ K01789 270 -1 "Site" "Negative 270"
         @ K01789 280 +1 "Site" "Positive 280"
         @ K01789 229.0 -1 "dnaA" "+12.2 bits " 12.200338 -0.473212 0.318031
*)
      id: string; (* name of the sequence piece the feature is on *)
      featurenumber: integer; (* the number of the feature read in *)
      featuregroup: integer; (* the group the feature is a member of *)
      featureisfirstingroup: boolean; (* is this the first feature of a group? *)
      coordinate: real; (* location of zero base *)
      orientation: integer; (* -1 or +1 is in direction of piece *)
      nametag: string; (* the name tag - name of the feature *)
      othertag: string; (* the other tag - another tag for misc use *)
      (* ---------------------------- *)
      definition: definitiontypeptr; (* the definition of the feature *)
      (* ---------------------------- *)
      (* the following three values are only defined when there
         is a definition for the feature matrix *)
      Ri: real; (* individual information of this site *)
      Z: real; (* Z score for this site *)
      probability: real; (* probability for this site *)

      (* Three parameters replace Ri, Z and p when there is no matrix,
         Aparam, Bparam and Cparam.  If there is a matrix, Tparam
         will be blank.  Otherwise: *)
      Tparam: char; (* a parameter that defines the kind of parameter
                       that the remainder parameters are. *)
      Aparam: real; (* a parameter *)
      Bparam: real; (* a parameter *)
      Cparam: real; (* a parameter *)
      Dparam: real; (* a parameter *)
      relcoo: real; (* relative coordinate *)
         (* Since these parameters
         are now (2004 July 17) able to substitute for Ri, Z and
         probability, the Tparam cannot be placed in front of the
         three parameters in feature files.  Tparamvalues:
            h = hsb feature colors: hue, saturation, brightness
            r = rgb feature colors: red, green, blue
            b = bit range for the feature
            ' ' = defaults to sequence walker
         Summary:
         Tparam  Aparam     Bparam     Cparam     Dparam     For
          ' '    Ri         Z          P          (none)     walker
          'h'    hue        saturation brightness (none)     ascii lines
          'r'    red        green      blue       (none)     ascii lines
          'H'    hue        saturation brightness thickness  color bar
          'R'    red        green      blue       thickness  color bar
         In this scheme one can control the color of the bar as an
         ascii string OR one can control the colored rectangle behind
         the bar but NOT BOTH.
         *)
      (* ---------------------------- *)
      evencoordinate: real; (* location of zero base for asymmetric and odd
         symmetry sites, with 0.0 as the decimal.  For even symmetry sites
         it's the point of symmetry, with 0.5 as the decimal. *)
      (* ---------------------------- *)
      (* computed values: *)
      unsatisfied: boolean; (* true when the feature has not yet been used
                               during printing a line *)
      fromrange: real; (* the lower part of the feature *)
        torange: real; (* the higher part of the feature *)
      desiredline: integer; (* The line the feature wants to be printed on.
                            Zero means any value.  Line increases down the
                            page. *)
      (* There can be several features that this feature points to,
         From multiscan, Gap features have two and total features have
         at least two.  So others needs to be a list of features.
         This cannot be done on the feature list itself because that
         would wreck the feature list structure.  So the feature
         carriers are used.  Likewise, a single feature, such as
         an E. coli -35 promoter walker, can have several total features
         that point to it, representing several -10s.  So there can be
         several mother features. *)
      others:  featurecarrierptr; (* other features this feature points to! *)
      mothers: featurecarrierptr; (* The features that point to this feature *)
      (* ---------------------------- *)
      (* If this feature is duplicated, the next two pointers
      indicate the previous and next feature *)
      duplicateprevious: featuretypeptr;
{
      duplicatenext: featuretypeptr; (* making the chain go forward
        means we must search the entire list in featureinlist.
        This does not seem worthwhile yet. *)
}
{ppp}
      usedInGroup: boolean; (* feature has been used in the group *) 
      (* ---------------------------- *)
      next: featuretypeptr; (* the next feature recorded *)
   end;
(* end module definition.feature.type version = 13.33; (@ of lister.p 2017 Feb 14 *)

      (* a type for the quicksort module, for testing quicksort and interact *)
{2003 Mar 16: This is a pain and not useful.
      position = 0..maxstring;
}
      (* a mapping for a string, used to test quicksort *)
      maptype =  array[1..maxstring] of 1..maxstring;

var
list: text; (* temporary file for debugging *) {ddd}
      (* variables for testing figure and quicksort *)
      buffer: string; (* a string that the user types *)
      newline: boolean; (* keep track of new typed lines *)
      atoken: string; (* a token found in the buffer string *)
      ourplace: integer; (* for keeping track of the place during tokenizing *)
      map: maptype; (* pointers into the buffer string.  they are sorted *)
      control: char; (* the first letter of buffer, used to control the test *)
      gotten: boolean; (* used by interactive routines *)
      spaces, first, last, lines: integer; (* for numbar *)
      radius: real; (* for testing reading of reals *)

(* begin module feature.globals *)
(* globals needed by lister.p: *)
   groupnumber: integer; (* counted group number *)
(* end module feature.globals *)

(* begin module package.numbar *)
(* ************************************************************************ *)
(* begin module numberdigit *)
(* end module numberdigit *)

(* begin module numbersize *)
(* end module numbersize *)

(* begin module numberbar *)
(* end module numberbar *)
(* ************************************************************************ *)
(* end module package.numbar *)

(* begin module package.interact *)
(* ************************************************************************ *)
(* begin module interact.prompt *)
(* end module interact.prompt *)

(* begin module interact.readchar *)
(* end module interact.readchar *)

(* begin module clearstring *)
(* end module clearstring *)

(* begin module interact.readstring *)
(* end module interact.readstring *)

(* begin module interact.figurestring *)
(* end module interact.figurestring *)

(* ************************************************************************ *)
(* end module package.interact *)

(* begin module package.interact.gets *)
(* ************************************************************************ *)
(* begin module interact.nostring *)
(* end module interact.nostring *)

(* begin module writestring *)
(* end module writestring *)

(* begin module interact.flagstring *)
(* end module interact.flagstring *)

(* begin module interact.getchar *)
(* end module interact.getchar *)

(* begin module interact.getinteger *)
(* end module interact.getinteger *)

(* begin module interact.getreal *)
(* end module interact.getreal *)

(* begin module interact.token *)
(* end module interact.token *)

(* begin module interact.gettoken *)
(* end module interact.gettoken *)

(* ************************************************************************ *)
(* end module package.interact.gets *)

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

(* begin module clearstring *)
(* end module clearstring *)

(* begin module writestring *)
(* end module writestring *)

(* begin module filler.fillstring *)
(* end module filler.fillstring *)

(* begin module filler.filltrigger *)
(* end module filler.filltrigger *)

(* begin module trigger.proc *)
(* end module trigger.proc *)

(* begin module skipblanks *)
(* end module skipblanks *)

(* ************************************************************************ *)
(* end module package.trigger *)

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

(* 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.16 84 mar 12 tds/gds'; *)

(* begin module between *)
function between(a,b,c: real):boolean;
(* is b between a and c? *)
begin between:=(a<=b) and (b<=c) end;
(* end module between *)

(* begin module copyline *)
procedure copyline(var fin, fout: text);
(* copy a line from file fin to file fout
but DO NOT CARRIAGE RETURN on the fout.
Carriage return on the fin. *)
begin (* copyline *)
      while not eoln(fin) do begin
         fout^ := fin^;
         put(fout);
         get(fin)
      end;
      readln(fin);
end; (* copyline *)
(* end module copyline *)

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

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

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

(* begin module skipblanks *)

(* 2003 July 31: tab is considered a blank character *)

function isblank(c: char): boolean;
(* is the character c blank or tab? *)
const
   tab = 9; (* tab character *)
begin
   isblank := (c = ' ') or (ord(c) = tab)
end;

procedure skipblanks(var thefile: text);
(* skip over blanks until a non-blank, or end of line, is found *)
begin
   while isblank(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 (not isblank(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 = 1.28;  (@ of genhis, 1985 mar 9 *)

{ OLD PROCEDURES:  tab previously was not a blank.
They are held here "just in case" but won't be transferred by
the module program.
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;
}

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

(* 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 = 1.10; (@ of same 1985 feb 19 *)

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

(* begin module plural *)
procedure plural(var thefile: text; number: integer);
(* if the number is not 1, return an s *)
begin (* plural *)
      if number <> 1 then write(thefile,'s')
end; (* plural *)
(* end module plural version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module checknumber *)
function checknumber(var afile: text): boolean;
(* check that there is a number next in the file.  If not, return
false.   This is useful for protection when reading a parameter file. *)
var ok: boolean; (* result of this check *)
procedure conclude;
begin
   writeln(output,'Including this character, the rest of the data line is:');
   copyaline(afile,output);
   ok := false;
end;
begin
   ok := true; (* be optimistic *)
   if eof(afile)
   then begin
      ok := false;
      write  (output,'A number was expected on a data line, but');
      writeln(output,' the end of the file was found instead.');
   end
   else begin
      skipblanks(afile);
      if eoln(afile) then begin
         write  (output,'A number was expected on a data line, but');
         writeln(output,' the end of the line was found instead.');
         conclude;
      end;
      if not (afile^ in
         ['0','1','2','3','4','5','6','7','8','9','.','-','+']) then begin
         write  (output,'A number was expected on a data line, but');
         writeln(output,' the character "',afile^,'" was found instead.');
         conclude;
      end;
   end;
   checknumber := ok
end;
(* end module checknumber version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module copyfile *)
procedure copyfile(var fin, fout: text);
(* copy the rest of file fin to fout *)
begin
   while not eof(fin) do copyaline(fin, fout);
end;
(* end module copyfile *)

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

(* begin module numbar.info *)
(* numbar: routines that make it easy to write a bar of numbers
out on the page.  these are very convenient for making graphs.

      the function numberdigit takes a number as input, and the log (base ten)
of the place value (called logplace) desired.  a character for that spot is
returned.   example:
      numberdigit(246,2) = 2

      the function numbersize determines the number of characters required
for printing the number (including the sign).

the procedure numberbar uses numberdigit and numbersize to write a bar of
numbers into a file, with several spaces before.  the range of numbers is
specified, and the number of lines written is returned.

         example:
      numberbar(output,5,-20,20,lines);    gives

     -----------                   +++++++++++
     21111111111--------- +++++++++11111111112
     09876543210987654321012345678901234567890

      3 lines were written.

*)
(* end module numbar.info version = 'prgmod 3.88  82 nov  3 tds'; *)

(* 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
2000 July 30 'myabsolute' replaced 'absolute', which
is apparently a keyword for GPC.  The name is kept
to keep the code looking similar to its origin.
*)
var
      place: integer; (* the exponent of logplace *)
      count: integer; (* used to make place *)
      myabsolute: integer; (* the absolute value of number *)
      acharacter: char; (* the character to be returned *)
procedure digit;
(* extract a digit at the place position *)
var
      tenplace: integer; (* ten times place *)
      z: integer; (* an intermediate value *)
      d: integer; (* the digit extracted *)
begin (* digit *)
      tenplace:=10*place;
      z:=myabsolute-((myabsolute div tenplace)*tenplace);
      if place = 1
         then d:=z
         else d:= z div place;
      case d of
         0: acharacter:='0';
         1: acharacter:='1';
         2: acharacter:='2';
         3: acharacter:='3';
         4: acharacter:='4';
         5: acharacter:='5';
         6: acharacter:='6';
         7: acharacter:='7';
         8: acharacter:='8';
         9: acharacter:='9';
      end
end; (* digit *)
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
         myabsolute:=abs(number);
         if myabsolute < (place div 10)
            then acharacter:=' '
            else if myabsolute >= place
                    then digit
                    else sign
      end;
      numberdigit:=acharacter
end; (* numberdigit *)
(* end module numberdigit version = 'prgmod 3.88  82 nov  3 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 *)
var
   size: integer; (* intermediate result *)
begin (* numbersize *)
   if n = 0
   then numbersize:=1
   else begin
      size:=trunc(ln(abs(n))/ln10 + epsilon) + 1;
      (* the 1 is for the last digit *)
      (* the epsilon assures that we do not lose a place due to
         roundoff.  eg, sometimes log base 10 of 10 would be 0.9999
         instead of 1, and we would not do it right...  note: this will
         fail for very large numbers on the order of 1/epsilon. *)
      if n < 0 then size := succ(size);  (* account for minus sign *)
      numbersize := size;
   end
end; (* numbersize *)
(* end module numbersize *)

(* begin module numberbar *)
function firstlastmax(firstnumber, lastnumber: integer): integer;
(* compute the sizes of firstnumber and lastnumber (including + or -
sign) and then determine which number is larger *)
var
   firstlines: integer; (* number of lines needed for firstumber *)
   lastlines: integer; (* number of lines needed for lastnumber *)
begin
   firstlines := numbersize(firstnumber);
   if firstnumber > 0
   then firstlines := firstlines + 1; (* add one more for + sign *)
   lastlines := numbersize(lastnumber);
   if lastnumber > 0
   then lastlines := lastlines + 1; (* add one more for + sign *)
   if firstlines > lastlines
   then firstlastmax := firstlines
   else firstlastmax := lastlines;
end;

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 *)
   number: integer; (* the current number being written *)
   spacecount: integer; (* count of spaces *)
begin
{ 2000 June 24:  This code was not sufficient to deal with the sign
correctly.  The numbersize routine now does *not* give the + sign
(which makes it useful for other purposes) so we have to account
for it here now.
   if abs(firstnumber) > abs(lastnumber)
      then linesused:= numbersize(firstnumber)
      else linesused:= numbersize(lastnumber);
}
   linesused := firstlastmax(firstnumber, lastnumber);
{
writeln(output,'numberbar says linesused = ',linesused:1);
      for logplace:=linesused-1 downto 0 do begin
1999 July 15: this is changed to linesused since numbersize now
accounts for the sign:
   for logplace := linesused downto 0 do begin
2000 June 24:  back to the old code ...
}
   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 = 4.36; (@ of prgmod.p 1999 July 22 *)

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

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

(* begin module interact.info *)

(* interactive reading routines protected from user errors

   these routines were written to protect the user from typing
errors made during interactive sessions.  the problem is that pascal (e.t.h.
zuerich / univ. of minn pascal-6000 v3.2.0 at univ of colo) will bomb when
one types several carriage returns.  there are several problems with
interactive programs in pascal, having to do with the way files are
manipulated.  since it is desirable, and even necessary in some cases
to have interactive programs, this set of procedures was devised.
you may find that the routines prompt and readchar must be modified to
fit the protocol on your computer.  readstring is less likely to require
modification.
      the higher level string manipulation
procedures should be completely transportable. *)

(* end module interact.info *)

(* begin module interact.prompt *)
procedure prompt(var afile: text);
(* prompt a file.
   the prompt is sent to the output file, and
   a line is read into the pascal line buffer.
   (for the cyber system this means to readln afile.)
   guarantee no bomb *)
begin (* prompt *)
      if eof(afile) then reset(afile);
      readln(afile);
end; (* prompt *)
(* end module interact.prompt *)

(* begin module interact.readchar *)
procedure readchar(var afile:text; var ch: char);
(* read a character from afile, guarantee no bomb *)
begin (* readchar *)
      if eof(afile) then prompt(afile);
      read(afile,ch);
(*writeln(output,'"',ch,'"') *)
end; (* readchar *)
(* end module interact.readchar *)

(* begin module clearstring *)
(* These modules clear strings in various ways *)
(* ---- *)
procedure emptystring(var ribbon: string);
(* empty the contents of the string but do NOT
remove the pointer.  This is useful for clearing
one string within a linked list of them. *)
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; (* emptystring *)
(* ---- *)
procedure clearstring(var ribbon: string);
(* empty the string and remove the pointer.
As of 2010 Dec 04 there is a previous pointer that
allows proper removal of the linked list using disposestring.
This clearstring routine is for the initial clearing
of the variables. *)
begin (* clearstring *)
   with ribbon do begin
      emptystring(ribbon);
      previous := nil;
      next := nil;
   end
end; (* clearstring *)
(* ---- *)
procedure disposestring(var ribbon: stringptr);
(* remove the linked list from the string in revere order *)
var
   t: stringptr; (* a link in the string *)
begin
   t := ribbon;
   (* find the end *)
   while t^.next <> nil do t := t^.next;
   (* move backwards and dispose links *)
   while t^.previous <> nil do begin
      t := t^.previous;
      dispose(t^.next);
   end;
   dispose(t);
end; (* disposestring *)
(* ---- *)
procedure initializestring(var ribbon: string);
(* start the string with a nil pointer.   This routine
should be called before doing linked list work.  This allows
the standard string routines to clear the string without
killing the pointer.  This is now deprecated, do not use it
since clearstring still clears the next pointer. *)
begin (* initializestring *)
   writeln(output,'remove initializestring routine!');
   writeln(output,'replace it with clearstring routine!');
   halt; (* to force deprecation *)
   clearstring(ribbon);
   ribbon.next := nil;
end; (* initializestring *)
(* end module clearstring *)

(* begin module interact.readstring *)
procedure readstring(var afile: text; var line: string);
(* read in a string from afile, protect against bombing *)
var
      index: integer; (* for line *)
      cha: char; (* a character read in *)
      done: boolean; (* used for removing trailing blanks from the line *)
      acceptable: boolean; (* was the line typed short enough? *)
begin (* readstring *)
      with line do begin
         repeat
            clearstring(line);
            prompt(afile);
            index := 0; (* we now count characters *)
            while (not eoln(afile)) and (index < maxstring) do begin
               index:=succ(index);
               readchar(afile,cha);
               line.letters[index]:=cha
            end;
            if not eoln(afile)
            then begin
               writeln(output, 'type lines shorter than ', (maxstring+1): 1,
                               ' characters.  please retype the line...');
               acceptable := false
            end
            else acceptable := true
         until acceptable;

         length := index;
         if length > 0 then begin
            done := false;
            repeat (* remove blanks from the line.  note that a while loop
                  can not be used because one must avoid letters[0], since that
                  position does not exist... *)
               if letters[length] = ' '
               then length := pred(length)
               else done := true;

               if length = 0 then done := true
            until done
         end;

         if length > 0 then current := 1
                       else current := 0
      end
end; (* readstring *)
(* end module interact.readstring *)

(* begin module interact.figurestring *)
procedure figurestring(
      var line: string; (* a string of characters to figure out *)
      var first: integer; (* first found non-blank character in the line *)
      var last:  integer; (* last character before a blank after first *)
      var whzat: char; (* what the token is *)
      var c:     char;  (* the first character of the token *)
      var i:     integer; (* integer value of token if it is integer; or 0 *)
      var r:     real); (* the real value if it is real; or 0.0 *)
(* figurestring figures out the tokens in a string.
 it recognizes words, integers, reals and poorly formed numbers.
 you can easily use it to parse lines.

our goal is to figure out what thing is on a string.
start looking at the current place on the line.
first and last are the first 'token' in line after start.
the current place is updated to the letter after last.
the thing found is described by the value of whzat:
      'c': character (when the token does not begin with a digit, '+', or '-')
      'i': integer
      'r': real
      ' ': blank line
      'g': garbage, cannot figure it out
and the value of the thing found is the appropriate variable *)
var
      numbers: set of '0'..'9';
      sign: integer; (* sign of a number *)
      numberstart: integer; (* the point a number starts,
                               beyond its sign, if any *)
      point: integer; (* location of decimal point *)
      power: integer; (* of 10 representing a place value in the number *)

      l: integer; (* an index for dissecting numbers *)

function figureinteger(first,last:integer):integer;
(* figure the integer in the token *)
var
      i: integer; (* index *)
      sum, increment: integer;
begin (* figureinteger *)
      power:=1; (* start at ones place *)
      sum:=0; (* start sum at zero *)
      for i:=last downto first do begin
         case line.letters[i] of
            '0': increment:=0;
            '1': increment:=1;
            '2': increment:=2;
            '3': increment:=3;
            '4': increment:=4;
            '5': increment:=5;
            '6': increment:=6;
            '7': increment:=7;
            '8': increment:=8;
            '9': increment:=9
         end;
         sum:=sum+power*increment;
         power:=power*10
      end;
      figureinteger:=sum
end; (* figureinteger *)

begin (* figurestring *)
      numbers:=['0','1','2','3','4','5','6','7','8','9'];
(* c:=' '; i:=0; r:=0.0; do not affect these variables unless necessary *)
      point:=0;
      whzat := '.'; (* assume that we have someting to work on *)
      (* now to see if that is true: *)

      with line do if (length = 0) or (current < 1) or (current > length)
      then whzat := ' '
      else begin
         (* figure out where the first token is in the line *)
         first:=line.current;
         while (line.letters[first]=' ') and (first < line.length)
            do first:=succ(first);
         if (first = line.length) and (line.letters[first] = ' ')
            then whzat := ' ';
      end;

      if whzat <> ' ' then begin
         last:=first;
         while (line.letters[last]<>' ') and (last < line.length)
            do last:=succ(last);
         if line.letters[last] = ' ' then last := pred(last);

         (* the token is between inclusive first and last *)

         c:=line.letters[first];
         if (c in numbers) or (c in ['+','-']) then begin
            if c in ['+','-'] then begin
               case c of
                  '+': sign:=+1;
                  '-': sign:=-1;
               end;
               numberstart:=succ(first)
            end
            else begin
               sign:=+1;
               numberstart:=first
            end;

            whzat:='i';
            for l:=numberstart to last do begin
               if not(line.letters[l] in numbers)
               then if line.letters[l]='.' (* we found a period *)
                  then if whzat='i' (* if so far it is numbers *)
                     then begin
                        whzat:='r'; (* it is actually real *)
                        point:=l
                     end
                     else whzat:='g' (* it is a second '.', ie garbage *)
                  else whzat:='g' (* it is garbage *)
            end;
            (* if it is only numbers, it is integer *)

            (* build number *)
            (* if it ends in a period, it is integer *)
            if (whzat = 'r') and (point = last) then whzat:='i';

            if whzat = 'i' then begin
               if point = last (* had an ending decimal point *)
               then i:=sign * figureinteger(numberstart,pred(last))
               else i:=sign * figureinteger(numberstart,last);
               r:=i
            end
            else if whzat = 'r' then begin
               i:=figureinteger(numberstart,point-1);
               r:=sign * (i+figureinteger(point+1,last)/power);
               i:=sign * i
            end
         end
         else begin
            whzat:='c';
         end;

         (* move the start to just beyond the last character of the token *)
         line.current:=succ(last)
      end
end; (* figurestring *)

(* end module interact.figurestring *)

(* begin module interact.get.info *)
(* the nostring function and the get procedures are to be used in code
   which looks like this:

      var buffer: string;         ( an interactive buffer )
      ...
      clearstring(buffer);
      repeat
         if nostring(buffer) then writeln(output,'prompt message');
         getchar(afile,buffer,ch,gotten);

                                 ( now check that the character is correct )
         if gotten then if not (ch in ['a',...])
         then begin
            clearstring(buffer);
            writeln(output,' error message');

            gotten:=false
         end
      until gotten;

   in this way, the prompt need not be passed to the procedures, and a
   series of tokens (separated by blanks) can be typed on one line.
   if a token is found in the buffer string, then the prompt is not
   sent to the user.

   warning: the get procedures are designed to work following the
   nostring call in a loop.  they may not function correctly if used
   in other configurations.

*)
(* end module interact.get.info *)

(* begin module interact.nostring *)
function nostring(var buffer: string): boolean;
(* true if there are no characters in the rest of the buffer;
   false if there are characters.
   also, if there is no buffer, then buffer.length is set to 0 *)
var   answer: boolean; (* the answer returned *)
procedure kill;
(* destroy the line *)
begin (* kill *)
      answer := true; (* blood and gore *)
      clearstring(buffer) (* total death *)
end; (* kill *)
begin (* nostring *)
      with buffer do begin
         if length > 0 then begin
            if length < maxstring
            then while (letters[current] = ' ') and (current < length)
               do current := succ(current);

            if current <= maxstring
            then if letters[current] = ' '
                 then kill
                 else answer := false
            else kill
         end
         else kill
      end;
      nostring := answer
end; (* nostring *)
(* end module interact.nostring *)

(* begin module copystring *)
procedure copystring(a: string; var b: string);
(* copy string a to b.  The length, characters and
where the string points to are all copied. *)
var l: integer; (* index to the string *)
begin
   b.length := a.length;
   for l := 1 to a.length do b.letters[l] := a.letters[l];
   b.current := a.current;
   b.next := a.next;
end;
(* end module copystring *)

(* begin module detabstring *)
procedure detabstring(var s: string);
(* Tabs are converted to blanks.  This allows the tab to be a special "solid"
kind of blank, but the string written won't vary with position on the line
depending on the tabstops. *)
const
   tabcharacter = 9; (* the ordinal of the tab character *)
var
   c: char; (* a character write out *)
   i: integer; (* index to the string s *)
begin
   with s do for i := 1 to length do begin
      c := letters[i];
{
for testing:
      if ord(c) = tabcharacter then c := 'T'; (* tab converted to blank *)
}
      if ord(c) = tabcharacter then c := ' '; (* tab converted to blank *)
      letters[i] := c
   end;
end;
(* end module detabstring version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module 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 writestring *)

(* begin module writeNOTABstring *)
procedure writeNOTABstring(var tofile: text; var s: string);
(* write the string s to file tofile, no writeln, remove
all tab characters first. *)
var   notabs: string; (* no tab version of s *)
begin (* writeNOTABstring *)
   copystring(s,notabs);
   detabstring(notabs);
   writestring(tofile,notabs);
end; (* writeNOTABstring *)
(* end module writeNOTABstring *)

(* begin module interact.flagstring *)
procedure flagstring(var afile: text; var buffer: string);
(* flag an error in the buffer at the current place, and clear the buffer *)
begin (* flagstring *)
      with buffer do length := current; (* chop off the rest of the buffer *)
      writestring(afile, buffer); (* show the buffer *)
      write(afile,'? ');
      clearstring(buffer)
end; (* flagstring *)
(* end module interact.flagstring *)

(* begin module interact.getinteger *)
procedure getinteger(var afile: text; var buffer: string;
                     var int: integer; var gotten: boolean);
(* get the integer int from the buffer or interactive file afile *)
var
      (* variables for calling figurestring: *)
      first: integer;
      last: integer;
      what: char;
      cha: char;
      rea: real;
begin (* getinteger *)
      if buffer.length = 0
      then begin
         gotten:=false;
         readstring(afile,buffer)
      end
      else begin
         figurestring(buffer,first,last,what,cha,int,rea);

         if what <> 'i'
         then begin
            flagstring(output,buffer);
            writeln(output,' please type an integer');
            gotten:=false
         end
         else gotten:=true
      end
end; (* getinteger *)
(* end module interact.getinteger *)

(* begin module interact.getreal *)
procedure getreal(var afile: text; var buffer: string;
                  var rea: real; var gotten: boolean);
(* get the real rea from the buffer or interactive file afile
integer values are also accepted. *)
var
      (* variables for calling figurestring: *)
      first: integer;
      last: integer;
      what: char;
      cha: char;
      int: integer;
begin (* getreal *)
      if buffer.length = 0
      then begin
         gotten:=false;
         readstring(afile,buffer)
      end
      else begin
         figurestring(buffer,first,last,what,cha,int,rea);

         if not (what in ['r', 'i'])
         then begin
            flagstring(output,buffer);
            writeln(output,' please type a real number');
            gotten:=false
         end
         else gotten:=true
      end;

      (* handle integers *)
      if what = 'i' then rea := int
end; (* getreal *)
(* end module interact.getreal *)

(* begin module interact.getchar *)
procedure getchar(var afile: text; var buffer: string;
                  var cha: char; var gotten: boolean);
(* get a character from the buffer, or refill the buffer and
   let the calling program figure out whether the buffer has non
   blank characters in it. *)
var
      (* variables for calling figurestring: *)
      first: integer;
      last: integer;
      what: char;
      int: integer;
      rea: real;
begin (* getchar *)
      if buffer.length = 0 then begin
         gotten:=false;
         readstring(afile,buffer)
      end
      else begin
         figurestring(buffer,first,last,what,cha,int,rea);
         gotten := (what <> ' ')
      end
end; (* getchar *)
(* end module interact.getchar *)

(* begin module interact.token *)
procedure token(var buffer, atoken: string; var gotten: boolean);
(* get a token from the buffer *)
var
      (* variables for calling figurestring: *)
      first: integer;
      last: integer;
      what: char;
      cha: char;
      int: integer;
      rea: real;
      index: integer; (* to the buffer *)
begin
      figurestring(buffer,first,last,what,cha,int,rea);

      if what = ' '
      then gotten := false
      else begin
         clearstring(atoken);
         for index := first to last
            do atoken.letters[index-first+1] := buffer.letters[index];
         atoken.length := last - first + 1;
         atoken.current := 1;

         gotten:=true
      end
end;
(* end module interact.token *)

(* begin module interact.gettoken *)
procedure gettoken(var afile: text; var buffer: string;
                   var atoken: string; var gotten: boolean);
(* get a token from the buffer or interactive file afile *)
begin (* gettoken *)
      if buffer.length = 0
      then begin
         gotten:=false;
         readstring(afile,buffer)
      end
      else token(buffer,atoken,gotten)
end; (* gettoken *)
(* end module interact.gettoken *)

(* begin module onetoken *)
procedure onetoken(var afile: text; var buffer: string;
                  var gotten: boolean);
(* Get a string from a file not using string calls.  This lets one
obtain lines from a file without interactive prompts.  if end of file
is found, gotten is false. *)
const
   tabcharacter = 9; (* the ordinal of the tab character *)
var   index: integer; (* of buffer *)
      done: boolean;
begin (* onetoken *)
   skipblanks(afile);
   emptystring(buffer);
   done := false;
   if eof(afile)
   then gotten := false
   else begin
      index := 0;
      while (not eoln(afile)) and (index < maxstring)
         and not done
      do begin
         index := succ(index);
         read(afile, buffer.letters[index]);
         if    (buffer.letters[index] = ' ')
            or (ord(buffer.letters[index]) = tabcharacter)
         then begin
            done := true;
            index := pred(index);
         end
      end;
      buffer.length := index;
      buffer.current := 1;
      gotten := true
   end
end;
(* end module onetoken *)

(* begin module interact.getstring *)
procedure getstring(var afile: text; var buffer: string;
                    var gotten: boolean);
(* get a line (as a string) from a file not using string calls.  this lets
one obtain lines from a file without interactive prompts *)
var   index: integer; (* of buffer *)
begin (* getstring *)
      clearstring(buffer);
      if eof(afile)
      then gotten := false
      else begin
         index := 0;
         while (not eoln(afile)) and (index < maxstring) do begin
            index := succ(index);
            read(afile, buffer.letters[index])
         end;
         if not eoln(afile) then begin
            writeln(output, ' getstring: a line exceeds maximum string size (',
                            maxstring:1,')');
            halt
         end;
         buffer.length := index;
         buffer.current := 1;
         readln(afile);
         gotten := true
      end
end; (* getstring *)
(* end module interact.getstring *)

(* begin module readstringline *)
procedure readstringline(var afile: text; var buffer: string);
(* get a line (as a string) from a file. *)
var   index: integer; (* of buffer *)
begin (* getstring *)
   clearstring(buffer);
   index := 0;
   while (not eoln(afile)) and (index < maxstring) do begin
      index := succ(index);
      read(afile, buffer.letters[index])
   end;
   if not eoln(afile) then begin
      writeln(output, 'readstringline: a line exceeds maximum string size (',
                      maxstring:1,')');
      halt
   end;
   buffer.length := index;
   buffer.current := 1;
   readln(afile);
end; (* readstringline *)
(* end module readstringline *)

(* begin module writestringlines *)
procedure writestringlines(var afile: text; l: stringptr);
(* write lines of strings to a file. *)
var
   h: stringptr; (* pointer to l *)
begin (* getstring *)
   if l <> nil then begin
      h := l;
      while h <> nil do begin
         writestring(afile, h^);
         writeln(afile);
         h := h^.next;
      end;
   end
end;
(* end module writestringlines *)

(* begin module writequotestring *)
procedure writequotestring(var afile: text; s: string);
(* Write the string s to afile, surrounded by double quote marks.  Tabs are
converted to blanks.  This allows the tab to be a special "solid" kind of
blank, but the string written won't vary with position on the line depending
on the tabstops. *)
begin
   detabstring(s);
   write(afile, '"');
   writestring(afile, s);
   write(afile, '"');
end;
(* end module writequotestring version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module readquotestring *)
procedure readquotestring(var afile: text; var s: string);
(* read the quoted string from afile, remove the quotes.  Trailing
blanks are converted to tab characters. *)
const
   tabcharacter = 9; (* the ordinal of the tab character *)
var
   c: char; (* a character read *)
   i: integer; (* index to the string s *)
begin
   emptystring(s);
   skipblanks(afile);
   with s do begin
      read(afile,c);
      if c <> '"' then begin
         writeln(output, 'quote string expected but " missing');
         writeln(output, 'character found instead:"',c,'"');
         halt
      end;
      if eoln(afile) then begin
         writeln(output, 'missing end of quote string " string');
         halt
      end;
      repeat
         read(afile,c);
         if c <> '"' then begin
            length := succ(length);
            letters[length] := c;
         end;
      until (c = '"')
            or eoln(afile) or (length = maxstring);
      if length = maxstring then begin
         writeln(output, 'A quote string exceeded ',maxstring:1,
                         ' characters.');
         writeln(output, 'Use a shorter string or increase constant',
                         ' maxstring.');
         halt
      end;
      if c <> '"' then begin
         writeln(output, 'The second " mark of a string is missing.');
         halt
      end;
      (* convert all blanks to tab characters *)
      for i := 1 to length do begin
         if letters[i] = ' '
         then letters[i] := chr(tabcharacter); (* set to tab character *)
      end;
   end;
end;
(* end module readquotestring version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module skipstringblanks *)

procedure skipstringblanks(var line: string);
(* skip blanks in the line *)
begin
   with line do while (letters[current] = ' ') and (current < maxstring)
   do current := succ(current)
end; (* skipstringblanks *)

procedure skipstringnonblanks(var line: string);
(* skip nonblanks in the line *)
begin
   with line do while (letters[current] <> ' ') and (current < maxstring)
   do current := succ(current)
end; (* skipstringblanks *)

procedure skipstringcolumn(var line: string);
(* skipstring over a data column in the line *)
begin
   skipstringblanks(line); skipstringnonblanks(line);
end;

procedure stringcolumn(line: string; column: integer; var datum: string);
(* extract the column from the line and put into the datum string.
Ignore leading blanks in defining a column. *)
const
{
   debug = true;
}
   debug = false;
var
   c: integer; (* index to the datum characters *)
   columnnumber: integer; (* current column in the line *)
   done: boolean; (* did we find the datum column *)
   positionbeg: integer; (* position of the datum, begin *)
   positionend: integer; (* position of the datum, end *)
begin
   columnnumber := 0;
   done := false;
   if debug then begin writestring(output, line); writeln(output); end;
   while not done do begin
       if (columnnumber = column) or (line.current >= line.length) then begin
          done := true;
       end
       else begin
          skipstringblanks(line);
          positionbeg := line.current;
          if debug then write(output,'|':line.current,' ',line.current:1);
          if debug then write(output,'"',line.letters[positionbeg],'"');
          if debug then writeln(output);
          
          skipstringnonblanks(line);
          positionend := line.current - 1;
          if debug then write(output,'|':line.current,' ',line.current:1);
          if debug then write(output,'"',line.letters[positionend],'"');
          if debug then writeln(output);

          columnnumber := succ(columnnumber);
       end;
   end;
   clearstring(datum);
   if columnnumber = column then begin
      datum.length := positionend - positionbeg + 1;
      for c := 1 to datum.length do begin
          if debug then write(output,line.letters[positionbeg + c - 1]);
          datum.letters[c] := line.letters[positionbeg + c - 1];
      end;
   end;
   if debug then writeln(output);
{
   if debug then halt;
}
end;

(* end module skipstringblanks *)

(* begin module stringtoreal *)
procedure stringtoreal(datum: string; var rea: real; var gotten: boolean);
(* convert the string to a real number if possible
integer values are also accepted. *)
var
      (* variables for calling figurestring: *)
      first: integer;
      last: integer;
      what: char;
      cha: char;
      int: integer;
begin (* stringtoreal *)
      if datum.length = 0
      then begin
         gotten:=false;
         rea := maxint;
      end
      else begin
         datum.current := 1; (* directs figurestring to the string *)
         figurestring(datum,first,last,what,cha,int,rea);
         if not (what in ['r', 'i'])
         then begin
            gotten:=false
         end
         else begin
            gotten:=true;
            if what = 'i' then rea := int (* handle integers *)
         end;
      end;
end; (* stringtoreal *)
(* end module stringtoreal *)

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

(* begin module parsestring *)
procedure parsestring(a: string; var tokens: stringptr);
(* Separate parts of string a into a linked list of parts in string
tokens.  Space and tab are used as separaters. the tokens pointer
needs to be initialized outside this procedure as nil.  I introduced
the previous pointer to strings to make it possible to dispose of the
tokens in reverse order. *)
var
   ia: integer; (* index for string b *)
   ib: integer; (* index for string b part *)
   tokennumber: integer; (* token number *)
   token: stringptr; (* pointer to a token string *)
begin
   tokennumber := 0;
   if tokens = nil then begin
      new(tokens);
   end
   else begin
      disposestring(tokens); (* remove any previous tokens properly *)
      new(tokens);
   end;
   clearstring(tokens^);
   ia := 1;
   token := tokens;
   while ia <= a.length do begin
      (* skip blanks *)
      while (isblank(a.letters[ia])) and (ia < a.length) do begin
         ia := succ(ia);
      end;
      if ia <= a.length then begin (* read characters *)
         ib := 1;
         tokennumber := succ(tokennumber);
         token^.length := 0;
         while (not (isblank(a.letters[ia]))) and (ia <= a.length) do begin
            token^.length := succ(token^.length);
            token^.letters[ib] := a.letters[ia];
            ib := succ(ib);
            ia := succ(ia);
         end;
         new(token^.next);
         emptystring(token^.next^);
         token^.next^.previous := token; (* create back link *)
         token := token^.next; (* step forward one link *)
      end;
   end;
   (* the last token should be empty, dispose of it *)
   if token^.length = 0 then begin
      if token^.previous <> nil then begin
         token^.previous^.next := nil; (* remove link from previous token *)
         dispose(token);
      end;
   end
   else begin
      writeln(output, 'parsestring end token error');
      halt;
   end;
end;
(* end module parsestring *)

(* begin module stringtointeger *)
procedure stringtointeger(token: string; var result: integer);
(* convert the token to an integer.
Code taken from figureinteger *)
var
      i: integer; (* index *)
      power: integer; (* power index *)
      sum, increment: integer;
begin (* figureinteger *)
      power := 1; (* start at ones place *)
      sum:=0; (* start sum at zero *)
      for i := token.length downto 1 do begin
         case token.letters[i] of
            '0': increment:=0;
            '1': increment:=1;
            '2': increment:=2;
            '3': increment:=3;
            '4': increment:=4;
            '5': increment:=5;
            '6': increment:=6;
            '7': increment:=7;
            '8': increment:=8;
            '9': increment:=9
         end;
         sum:= sum + power*increment;
         power := power*10
      end;
      result := sum;
end;
(* end module stringtointeger *)

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

(* begin module equalstring *)
function equalstring(a, b: string): boolean;
(* Test for equality between two strings at current positions.
NOTE:  A compiler bug results if one directly tests this way:
   if thedefinition^.nametag = aname
The reason is completely not clear!  I showed that the parts of the
strings were identical, but the whole was not by this test.
For this reason it is *critical to test strings with equalstring.
*)
var   index: integer; (* index to both strings *)
      equal: boolean; (* are letters in a and b the same? *)
begin (* equalstring *)
      if a.length = b.length
      then begin
         index := 1;
         repeat
            equal := (a.letters[index] = b.letters[index]);
            index := succ(index)
         until (not equal) or (index > a.length);
         equalstring := equal
      end
      else equalstring := false
end; (* equalstring *)
(* end module equalstring *)

(* begin module lessstring *)
function lessstring(a,b: string): boolean;
(* is string a before string b in the alphabet? *)
var
   done: boolean; (* done checking the strings *)
   l: integer; (* index to the string *)
begin
   (* note: lengths assumed equal *)
   l := 0;
   done := false;
 
   repeat
      l := l + 1;
 
      if l > a.length (* the whole strings matched *)
      then begin
         done := true;
         lessstring := false
      end
      else if(b.letters[l] <> a.letters[l]) then begin
              done := true;
              lessstring := (ord(b.letters[l]) > ord(a.letters[l]))
           end
   until done
end;
(* end module lessstring *)

(* begin module makenumber *)
procedure makenumber(name: string; var number: integer; var found: boolean);
(* make a integer number from the name.  If a number was not detected,
found is false. *)
var l: integer; (* position in the string *)
begin
   found := false;
   number := 0;
   for l := 1 to name.length do begin
      if name.letters[l] in ['0','1','2','3','4','5','6','7','8','9']
      then begin
         found := true;
         number := number * 10; (* make room for the next digit *)
         case name.letters[l] of
            '0': number := number + 0;
            '1': number := number + 1;
            '2': number := number + 2;
            '3': number := number + 3;
            '4': number := number + 4;
            '5': number := number + 5;
            '6': number := number + 6;
            '7': number := number + 7;
            '8': number := number + 8;
            '9': number := number + 9;
         end
      end
   end           
end;
(* end module makenumber *)

(* begin module concatstring *)
procedure concatstring(var a, b: string; var c: string);
(* concatenate a and b and put in c *)
var   abindex: integer; (* index to both strings *)
      cindex: integer; (* index to both strings *)
begin (* concatstring *)
   emptystring(c);
   c.length := a.length + b.length;
   if c.length > maxstring then begin
      writeln(output,'string too long in concatstring');
      halt
   end;

   cindex := 0;
   for abindex := 1 to a.length do begin
      cindex := succ(cindex);
      c.letters[abindex] := a.letters[abindex]
   end;

   for abindex := a.length+1 to a.length+b.length do begin
      cindex := succ(cindex);
      c.letters[abindex] := b.letters[abindex-a.length]
   end;
end; (* concatstring *)
(* end module concatstring *)

(* begin module attachstring *)
procedure attachstring(var a: string; b: string);
(* attach the string b onto the end of a *)
var
   hold: string; (* intermediate for doing the attachment *)
begin
   copystring(a, hold);
   concatstring(hold,b,a)
end;
(* end module attachstring *)

(* begin module attachcharacterstring *)
procedure attachcharacterstring(c: char; var a: string);
(* attach the character c to the end of a *)
begin
   if a.length = maxstring then begin
      writeln(output,'attachcharacterstring: maxstring exceeded');
      halt
   end;
   with a do begin
      length := succ(length);
      letters[length] := c
   end
end;
(* end module attachcharacterstring *)

(* begin module joinstring *)
procedure joinstring(parts: stringptr; var target: string);
(* the parts string contains one or more strings linked
together.  They are to be concatenated together and put on the end
of the target string *)
var
   p: stringptr; (* pointer into the parts *)
begin
   p := parts;
   while p <> nil do begin
      attachstring(target, p^);
      p := p^.next;
   end;
end;
(* end module joinstring *)

(* begin module numberstring *)
procedure numberstring(anumber: integer; var astring: string);
(* Convert an integer number into a string.  Positive numbers do
not have a sign.  REQUIRES: numbersize and numberdigit. *)
var
   d: integer; (* the digit extracted *)
   size: integer; (* size of the number in digits *)
begin
   clearstring(astring);
   size := numbersize(anumber) - 1;
   for d := 0 to size do begin
      astring.letters[1+size-d] := numberdigit(anumber, d);
   end;
   astring.length := size+1;
end;
(* end module numberstring version = 4.33; (@ of prgmod.p 1999 July 15 *)

(* begin module numberstringtest *)
procedure onenumberstringtest(var f: text; i: integer);  
(* One test of numberstring to file f.  The integer i
should be represented correctly as a string n. *)
var
   n: string; (* i converted into a string *)
   size: integer; (* size of the number in digits *)
begin  
   clearstring(n);
   write(f,'i= ',i:6);
   size := numbersize(i);
   write(f,' (size = ',size:1,') ');
   write(f,' n = "');
   numberstring(i,n);   
   writestring(f,n);
   write(f,'"');   
   writeln(f); 
end;  
 
procedure numberstringtest(var f: text); 
(* Test the numberstring routine.  Various values of integer i
should be represented correctly as a string n.
Output to file f. *)
const
   range = 15; (* the range of small numbers to test over *)
var i: integer; (* a number to test *)  
begin
   writeln(f,'* nu ',version:4:2);
   onenumberstringtest(f, -10000); 
   onenumberstringtest(f, -1000);    
   onenumberstringtest(f, -100);
   for i := -range to +range do begin
      onenumberstringtest(f, i); 
   end; 
   onenumberstringtest(f, +100);  
   onenumberstringtest(f, +1000);  
   onenumberstringtest(f, +10000); 
end;
(* end module numberstringtest *) 

(* begin module numberrealstring *)
procedure numberrealstring(var s: string;
                            n: real;
                            thewidth: integer;
                            thedecimal: integer);
(* Put the real number n into the string s taking up thewidth characters and
using thedecimal decimal places.  Note that the procedure multiplies n by a
perfectly integer power (which is quite clean) and then rounds that.  This
ensures that the last decimal place is rounded but no others.  Then the
program picks apart that clean number using numberdigit.  NOTE: If thewidth
is too small to fit the number then the size is increased.
Note:  The general rule is to throw away leading zeros EXCEPT in the
special case like 0.1!  This code does not account for that case.
2005 May 30: That's not acceptable.  No leading spaces are allowed
unless the string is shorter than thewidth.  Add a bit of code to do that.
*)
{
const dndebugpoint = -20; updebugpoint = -0;
const dndebugpoint = -1.1; updebugpoint = 100;
}
var
   decimalplace: integer; (* amount of space for a decimal place *)
   d: integer; (* one of the digit places *)
   digits: integer; (* the number n is multiplied by powers of 10 until
      all relevant digits are above zero.  Then it is rounded to produce
      'digits'.  This guarantees that the rounding is correct over the
      entire number. *)
   i: integer; (* index to the digits of the number *)
   power: integer; (* powers of 10 *)
   minus: boolean; (* whether we made a - *)
   newwidth: integer; (* the larger width to fit the number into *)
   sign: integer; (* amount of space for a sign *)
   symbol: char; (* a symbol to put into s *)
begin
   (* numberrealstring MUST NOT CALL clearstring(s); because
      clearstring WIPES OUT the rest of a linked list *)
   emptystring(s);
   if thewidth > 0 then with s do begin
      power := 1;
      for i := 1 to thedecimal do begin
         power := power * 10;
      end;
      digits := round(power*abs(n));
      if thedecimal > 0 then decimalplace := 1
                        else decimalplace := 0;
      if n < 0 then sign := 1
               else sign := 0;
      newwidth := numbersize(digits)+thedecimal+sign;

      (* add space for leading zero for numbers below abs(1).
      2005 May 30: This puts an extra space
      at the start of 0.97 when using only one decimal place.
      This must be removed later in some cases *)
      if abs(n) < 1.0 then newwidth := succ(newwidth);

      (* use the requested width if it is bigger *)
      if thewidth > newwidth
      then newwidth := thewidth;

{
if (n > dndebugpoint) and (n < updebugpoint) then begin
writeln(output);
write(output,'n = ',n:1:1);
write(output,'  n = ',n:thewidth:(thedecimal+3));
write(output,'  digits = ',digits:1);
write(output,'  trunc(n) = ',trunc(abs(n)):1);
write(output,'  numbersize(trunc(abs(n))) = ',numbersize(trunc(abs(n))):1);
writeln(output);
write(output,'  newwidth = ',newwidth:1);
write(output,'  thewidth = ',thewidth:1);
write(output,'  thedecimal = ',thedecimal:1);
writeln(output);
end;
}

      for d := newwidth-1-decimalplace downto 0 do begin
          symbol := numberdigit(digits,d);
{
if (n > dndebugpoint) and (n < updebugpoint) then begin
write(output,'        d = ',d:1:1);
write(output,'        symbol = ',symbol:1);
writeln(output);
end;
}
          if symbol = '-' then symbol := '0';
          if symbol = '+' then symbol := '0';
          if symbol = ' ' then symbol := '0';
          length := succ(length);
          letters[length] := symbol;
          if d = thedecimal then if thedecimal > 0 then begin
{
if (n > dndebugpoint) and (n < updebugpoint) then begin
write(output,'            at the decimal    = .');
writeln(output);
end;
}
             length := succ(length);
             letters[length] := '.';
          end;
      end;
{
if (n > dndebugpoint) and (n < updebugpoint) then begin
writequotestring(output,s); writeln(output);
end;
}

      (* convert leading zero's to blanks *)
      current := 1;
      while (letters[current] = '0') and (current < length) do begin
         if letters[current+1] <> '.' then letters[current] := ' ';
         current := succ(current);
{
if (n > dndebugpoint) and (n < updebugpoint) then begin
writequotestring(output,s); writeln(output);
end;
}

      end;
      (* now put the minus sign back *)
      if n < 0 then begin
         current := 1;
         minus := false;
         while letters[current] = ' ' do begin
            if letters[current+1] <> ' ' then begin
               letters[current] := '-';
               minus := true;
            end;
            current := succ(current);
            if current >= maxstring then begin
               write  (output,'numberrealstring:');
               writeln(output,' cannot place minus sign in string');
               writeln(output,'placing number at ',current:1);
               writeln(output,'the number is n =',n:newwidth:thedecimal);
               writestring(output,s);
               halt;
            end;
         end;
         if not minus then begin
            writeln(output,'numberrealstring ERROR:',
                           ' missing minus sign for number ',
                           n:newwidth:thedecimal);
            writeln(output,'Increase one of the number widths.');
            halt
         end;
      end;
   end;

   (* 2005 May 30: At this point the number 0.97 with one decimal
   place comes out as: " 1.0".  This is not acceptable, so remove
   any leading blanks. *)
   if s.length > thewidth
   then with s do while letters[1] = ' ' do begin
      for i := 1 to length - 1
      do letters[i] := letters[i + 1];
      length := length - 1;
   end;

{
if (n > dndebugpoint) and (n < updebugpoint) then begin
writeln(output,'s.length = ',s.length:1);
writeln(output,'n=',n:thewidth:thedecimal);
writequotestring(output,s); writeln(output);
end;
}

end;
(* end module numberrealstring version = 5.20; (@ of prgmod.p 2005 May 28 *)

(* begin module testnumberrealstring *)
procedure testnumberrealstring(var afile: text);
(* Test numberrealstring.  2005 May 30: the number 0.97
came out as " 1.0", which is unacceptable.  This test routine
allows one to try various values. *)
var
   s: string; (* a string *)
procedure test(var s: string; r: real);
begin
   numberrealstring(s, r, 1, 1);
   write(output,'for number = "',r:8:5,'"');
   write(output,          ' = "',r:1:1,'",');
   write(output,' string="');
   writestring(output,s);
   writeln(output,'"');
end;
begin
   writeln(output,'testnumberrealstring ');
(* numberrealstring(s, Ri, Riwidth, Ridecimal); *)
  clearstring(s);
  test(s,1.0);
  test(s,1.7);
  test(s,1.8);
  test(s,1.9);
  test(s,1.99);
  test(s,2.0);
  test(s,0.975901);
  test(s,0.97);
  writeln(output, 'Special cases');
  writeln(output);
  test(s,-3.97);
  test(s,-2.97);
  test(s,-1.97);
  test(s,-0.97);
  test(s,0.97);
  test(s,1.97);
  test(s,2.97);
  test(s,3.97);
  writeln(output, 'It is a special case!');
  writeln(output);
  test(s,-3.07);
  test(s,-2.07);
  test(s,-1.07);
  test(s,-0.07);
  test(s,0.07);
  test(s,1.07);
  test(s,2.07);
  test(s,3.07);
  writeln(output, 'It is a special case!');
end;
(* end module testnumberrealstring *)


(* begin module grabtoken *)
procedure grabtoken(var thefile: text; var thestring: string);
(* skip any blanks and then grab the next token from the file *)
var
   c: char; (* a character in thefile *)
   done: boolean; (* done finding the name *)
begin
   skipblanks(thefile);
   done := false;
   with thestring do begin
      length := 0;
      while not done do begin
         if eoln(thefile)
         then done := true
         else begin
            read(thefile,c);
            if c = ' '
            then done := true
            else begin
               length := succ(length);
               letters[length] := c;
            end
         end
      end
   end
end;
(* end module grabtoken *)

(* begin module capitalize *)
function capitalize(c: char): char; 
(* convert the character c to upper case *) 
var 
   n: integer; (* c is the n'th letter of the alphabet *)
begin 
   n := ord(c); 
   if (n >= ord('a')) and 
      (n <= ord('z'))   
   then c := chr( n - ord('a') + ord('A'));
   capitalize := c
end; 
(* end module capitalize *)
 
(* note: on 1990 May 7 decapitalize became a function *)

(* begin module decapitalize *)
function decapitalize(c: char): char; 
(* convert the character c to lower case *) 
var 
   n: integer; (* c is the n'th letter of the alphabet *)
begin 
   n := ord(c); 
   if (n >= ord('A')) and 
      (n <= ord('Z'))   
   then c := chr( n - ord('A') + ord('a'))
   else c := chr(n);
   decapitalize := c
end; 
(* end module decapitalize *)

(* begin module decapstring *)
procedure decapstring(var t: string);
(* convert capital letters in t to lower case *)
var
   i: integer; (* index to position in t *)
begin
   with t do for i := 1 to length
   do letters[i] := decapitalize(letters[i]);
end;
(* end module decapstring *)

(* begin module instring *)
procedure instring(buffer: string; bufferstart: integer;
                   tag: string; var gottag: integer);
(* If the tag string is in the buffer string (beyond bufferstart),
gottag is 0 if not found and the location if found. *)
var
   b: integer; (* position in buffer *)
   t: integer; (* position in tag *)
   tracking: boolean; (* tracking the tag in the buffer *)
begin
   b := bufferstart;
   if bufferstart < 1 then begin
      writeln(output,'instring: bufferstart must be positive, it is ',
               bufferstart:1);
      halt;
   end;
   t := 1;
   gottag := 0;
   tracking := false;
   while (b <= buffer.length) and (gottag = 0) do begin
      if decapitalize(buffer.letters[b]) = tag.letters[t] then begin
         tracking := true;
      end;
      if tracking then begin
         if decapitalize(buffer.letters[b]) = tag.letters[t] then begin
            if t = tag.length then begin
               gottag := b;
            end;
         end;
         t := succ(t);
      end;
      b := succ(b);
   end;
end;
(* end module instring *)

(* begin module alphabetic *)
function alphabetic(var c: char): boolean;
(* test that character c is alphabetic (either case) *)
var
   n: integer; (* c is the n'th letter of the alphabet *)
begin
   n := ord(c);
   if ( (n >= ord('A')) and (n <= ord('Z')) )
      or
      ( (n >= ord('a')) and (n <= ord('z')) )
   then alphabetic := true
   else alphabetic := false
end;
(* end module alphabetic *)

(* begin module whatisthere *)
procedure whatisthere(t: string; var charsok: boolean);
(* what characters are in the string t?  If it contains non-alphabetic
characters, charsok is false. *)
var
   i: integer; (* index to position in t *)
begin
   charsok := true;
   with t do for i := 1 to length
   do charsok := charsok and alphabetic(letters[i]);

   (* This works because any false case (ie, non alphabetic) will cause the
   entire thing to be false *)
end;
(* end module whatisthere *)

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

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

(* begin module filler.filltrigger *)
procedure filltrigger(var t: trigger;
                      a: filler);
(* fill the trigger t *)
begin (* filltrigger *)
         fillstring(t.seek,a)
end; (* filltrigger *)
(* end module filler.filltrigger *)

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

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

(* begin module demo *)
(* demonstration functions for prgmods *)
procedure setdemo(buffer: string; var map: maptype);
(* set up the map *)
var
      index: integer;
begin
      for index:=1 to buffer.length do map[index]:=index
end;

procedure print(var tofile: text; buffer: string; map: maptype);
(* print out the buffer string in the order of the map *)
var
      index: integer;
begin
      for index:=1 to buffer.length do write(tofile,buffer.letters[map[index]]);
      writeln(tofile)
end;

function lessthan(a, b: integer): boolean;
(* see quicksort *)
begin
      lessthan:=(buffer.letters[map[a]] < buffer.letters[map[b]])
end;

procedure swap(a,b: integer);
(* see quicksort *)
var
      hold: integer;
begin
      hold:=map[a];
      map[a]:=map[b];
      map[b]:=hold
(*;write(output,'a=',a:1,', b=',b:1); print (@ for testing *)
end;

(* end module demo *)

(* begin module quicksort *)

procedure quicksort(left, right: integer);
(* quick sort a list between positions left and right, into ascending order.
   a position is simply a scalar of the form 0..max.
   the array to be sorted is dimensioned 1..max.
(the difference in the ranges is important to the correct operation
of the sort...)
   two external routines are used:
      function lessthan(a, b: integer): boolean is a generalized test for
          value-at-a < value-at-b.
      procedure swap(a, b: integer) switches the items at positions a and b.
   since these routines are external, the procedure is general.

   this procedure taken from the book
   'algorithms + data structures = programs' by niklaus wirth,
   prentice-hall, inc., englewood cliffs, n.j.(1976), pp. 76-82 *)
var
      lower, upper: integer; (* the positions looked at currently *)
      center: integer; (* the rough center of the region being sorted *)
begin
      lower  := left;
      center := (left + right) div 2;
      upper  := right;

      repeat
         while lessthan(lower, center) do lower := succ(lower);
         while lessthan(center, upper) do upper := pred(upper);

         if lower <= upper then begin
            (* keep track of the center through the map: *)
                 if lower = center then center:=upper
            else if upper = center then center:=lower;
            swap(lower, upper);
            lower := succ(lower);
            upper := pred(upper)
         end
      until lower > upper;

      if  left < upper then quicksort(left,  upper);
      if lower < right then quicksort(lower, right)
end;

(* end module quicksort *)

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

(* Features and Definitions for Lister Maps (and other uses) *)

(* begin module readwaveparameters *)
procedure readawaveparameter(var afile: text; var wp: waveparam);
{
                                 cmperbase, cmperbit: real);
}
(* Read one wave parameter from a file. *)
{
2000 Nov 1:  The following experimental code is not implemented:
See the coscurve program
(https://alum.mit.edu/www/toms/delila/coscurve.html) for details
about the conversion from bases to cm.  The code now requires
cm per base and cmperbit.
const
   lover2pi = 1.2160067233; (* L/2pi for L being the length of
       the cosine function from 0 to 2pi *)
var
   multiplier: real; (* factor to multiply by to convert from bases to cm. *)
}
begin
   readln(afile,wp.extreme);
   readln(afile,wp.wavelocation);
   readln(afile,wp.wavebit);
   readln(afile,wp.waveamplitude);
   readln(afile,wp.wavelength);
   if wp.wavelength <= 0.0 then begin
      writeln(output,'wave parameters: wavelength must be positive');
      halt
   end;
   (* one may skip the dash and thickness parameters
      of the last wave definition.  This allows
      backwards compatability, but should not be
      used in general. *)
   if eof(afile)
   then begin
      wp.dashon := 0;
      wp.dashoff := 0;
      wp.dashoffset := 0;
      wp.thickness := 0
   end
   else begin
      (* implement new method to read dash information
         without breaking previous wave parameter files *)
      if afile^ <> 'd'
      then begin (* default to old method *)
         readln(afile,wp.dashon);
         wp.dashoff := wp.dashon;
         wp.dashoffset := 0;
      end
      else begin
         get(afile); (* skip the 'd' *)
         (* reading the parameters directly in cm would require
            that the user compute or guess the values.
            So read in as bases and compute cm.
            Unfortunately the length of a curve is not the simple
            scale factor.  Make the user guess for now.
         *)
         readln(afile,wp.dashon, wp.dashoff, wp.dashoffset)

{
experimental code to account for actual wave length:
         readln(afile, wp.BASEdashon, wp.BASEdashoff, wp.BASEdashoffset);
         multiplier    := 1;
         multiplier    := lover2pi
 * wp.waveamplitude (* in bits *)
 * cmperbit (* converts to cm *)
 / wp.wavelength (* 10.6 bp/turn *)
* cmperbase
;
multiplier    := lover2pi;
multiplier    := 1.0;
multiplier    := 1.0/lover2pi;
         multiplier := lover2pi
                       * wp.waveamplitude (* in bits *)
                       * cmperbit (* converts to cm *)
                       * wp.wavelength (* 10.6 bp/turn *)
                       * cmperbase;
         multiplier := 1.0
         wp.dashon     := multiplier * wp.BASEdashon;
         wp.dashoff    := multiplier * wp.BASEdashoff;
         wp.dashoffset := multiplier * wp.BASEdashoffset;
with wp do begin
   writeln(output, 'cmperbase  = ',cmperbase:5:2);
   writeln(output, 'cmperbit   = ',cmperbit:5:2);
   writeln(output, 'dashon     = ',dashon:5:2);
   writeln(output, 'dashoff    = ',dashoff:5:2);
   writeln(output, 'dashoffset = ',dashoffset:5:2);
   writeln(output, 'waveamplitude   = ',wp.waveamplitude:5:2);
   writeln(output, 'wavelength      = ',wp.wavelength:5:2);
end;
}

      end;
      if eof(afile)
      then wp.thickness := 0
      else readln(afile,wp.thickness);
   end;
end;

procedure readwaveparameters(var afile: text; var w: waveptr);
{
                                 cmperbase, cmperbit: real);
}
(* read from afile the wave parameters w.  The routine is done either at end
of file, when a period ('.') appears or at a blank line.  This makes it
compatable with different reading mechanisms. *)
var
   done: boolean; (* done reading *)
   morethanone: boolean; (* more than one wave? *)
   p: waveptr; (* one of the definitions of a cosine wave *)
procedure waystoend;
(* if end of file, a blank line or a period, consider the job done *)
var
   clear: boolean; (* not eof, so clear to test for comment *)
begin
   if eof(afile) then done := true;
   clear := false;
   if not done (* skip any number of comments *)
   then while (not clear) and (not done) do begin
      if eof(afile) then begin
         done := true;
         clear := true;
      end
      else if afile^ = '*'
           then readln(afile)
           else clear := true
   end;
   if not done then if eoln(afile) then done := true;
   if not done then if afile^='.' then begin
      readln(afile);
      done := true;
   end;
end;
begin
   done := false;
   morethanone := false;
   w := nil;
   waystoend;
   if not done then begin
      new(w);
      p := w;
      while not done do begin
         waystoend;
         if done
         then p^.next := nil
         else begin
            if afile^='*'
            then readln(afile) (* skip any number of comments *)
            else begin
               if morethanone then begin
                  new(p^.next);
                  p := p^.next
               end;
{
               readawaveparameter(afile, p^, cmperbase, cmperbit);
}
               readawaveparameter(afile, p^);
               (* if we ever come back again there will be more than one: *)
               morethanone := true;
            end
         end
      end
   end
   else w := nil;
end;
(* end module readwaveparameters *)

(* begin module writewaveparameters *)
procedure writewaveparameters(var afile: text; w: waveptr);
(* write wave parameters to a file *)
const
   wid = 4; (* width of numbers *)
var
   i: waveptr; (* pointer to the waves in w *)
begin
   i := w;
   while i <> nil do with i^ do begin
      writeln(afile,extreme,
                    '  extreme: char; h or l, the high or low extreme to be defined');
      writeln(afile,wavelocation:wid:1,
                    '  wavelocation: real; the location in bases of the extreme');
      writeln(afile,wavebit:wid:1,
                    '  wavebit: real; the location in bits of the extreme');
      writeln(afile,waveamplitude:wid:1,
                    '  waveamplitude: real; the amplitude of the wave in bits');
      writeln(afile,wavelength:wid:1,
                    '  wavelength: real; the wave length of the wave in bases');
{
      writeln(afile,dash:wid:1,
                    '  dash: real; the size of dashes in cm.',
                    '  dash <= 0 means no dashes');
      writeln(afile,    BASEdashon:wid:1,
                   ' ', BASEdashoff:wid:1,
                   ' ', BASEdashoffset:wid:1,
                   ' dashon, dashoff, dashoffset (in bases)');
}
      writeln(afile,    dashon:wid:1,
                   ' ', dashoff:wid:1,
                   ' ', dashoffset:wid:1,
                   ' dashon, dashoff, dashoffset (in bases)');
      writeln(afile,thickness:wid:1,
                    '  thickness: real; the thickness of the cosine wave.',
                    '  <=0 means default');
      i := i^.next
   end;
   writeln(afile,'.');
end;
(* end module writewaveparameters *)

(* begin module readheader *)
procedure readheader(var afile: text; ch: char; var theheader: stringptr);
(* Read the header from a file.  Only read lines that begin with ch.
2004 Dec 15: Handle end of file (eof) gracefully. *)
var
   h: stringptr; (* pointer to the riblheader *)
begin
   if eof(afile) then begin
      clearstring(theheader^);
   end
   else begin
      if afile^ = ch then begin
         new(theheader);
         h := theheader;
         while afile^='*' do begin
            readstringline(afile, h^);
            if not eof(afile) then begin
               if afile^='*' then begin
                  new(h^.next);
                  h := h^.next;
               end
               else h^.next := nil;
            end
         end
      end
      else begin
         theheader := nil
      end;
   end;
end;
(* end module readheader *)

(* begin module getriblmatrix *)
procedure getriblmatrix(var afile: text; var matrix: ribltypeptr);
(* Get the matrix from a file, with the defining coordinate limits,
followed by the mean and standard deviation and other data.
The entire matrix is read in. *)
const
   clearvalue = 5.0; (* If a large bit position is ever seen (for DNA), we
      KNOW there is a bug in the code! *)
var
   b: base; (* a base in the matrix *)
   l: integer; (* a coordinate in the matrix *)
   thel: integer; (* the l value in the file (should match l) *)

   teststring: string; (* string to test for 'ribl ' at matrix start *) 
   riblstart: string; (* word at the start of the matrix *)

procedure testforend;
(* test for end of file *)
begin
   if eof(afile) then begin
      writeln(output,'part or all of the ribl matrix is missing');
      halt;
   end
end;
procedure skip;
(* skip comment lines *)
begin
   testforend;
   while afile^='*' do begin
     readln(afile);
     testforend
   end
end;
begin
   new(matrix);
   with matrix^ do begin

      (* read name of the matrix *)
      grabtoken(afile, riblstart);
      teststring.letters[1] := 'r'; 
      teststring.letters[2] := 'i';
      teststring.letters[3] := 'b';
      teststring.letters[4] := 'l';
      teststring.length := 4; 
 
      if not equalstring(riblstart, teststring) then begin
         writeln(output,'The ribl matrix must begin with ''ribl "name"''');   
         writequotestring(output,riblstart);
         writeln(output, ' seen instead');
         halt
      end;
 
      skipblanks(afile); (* skip any spaces *)
      readquotestring(afile, matrix^.riblname);
      readln(afile);

      readheader(afile,'*',riblheader);

      readln(afile,frombase,tobase);

      if frombase < minribl then begin
         writeln(output,'Matrix is too large for program.');
         writeln(output,'frombase (=',frombase:1,')');
         writeln(output,'minribl (=',minribl:1,')');
         writeln(output,'Decrease minribl or increase frombase');
         halt
      end;

      if tobase > maxribl then begin
         writeln(output,'Matrix is too large for program.');
         writeln(output,'tobase (=',tobase:1,')');
         writeln(output,'maxribl (=',maxribl:1,')');
         writeln(output,'Increase maxribl or decrease tobase');
         halt
      end;

      (* clear unused matrix for safety *)
      for l := minribl to frombase-1
      do for b := a to t do matrix^.data[b,l] := clearvalue;
      for l := tobase+1 to maxribl
      do for b := a to t do matrix^.data[b,l] := clearvalue;

      for l := frombase to tobase do begin
         testforend;
         for b := a to t do read(afile,matrix^.data[b,l]);
         read(afile,thel);
         if thel <> l then begin
            writeln(output, 'positions in ribl do not match from-to range');
            halt;
         end;
         for b := a to t do read(afile,matrix^.numbers[b,l]);
         readln(afile)
      end;

      skip; readln(afile,mean);
      skip; readln(afile,stdev);
      skip; readln(afile,consensus);
      skip; readln(afile,anticonsensus);
      skip; readln(afile,averageRi);
      skip; readln(afile,n);
      skip; readln(afile,symmetry);
      skip; readln(afile,Ribound);
      skip; readln(afile,Zbound);
      skip; readln(afile,Pbound);
{this is a guess - set the converters to neutral for now
      cmperbase := 1.0;
      cmperbit := 1.0;
      readwaveparameters(afile, waves, cmperbase, cmperbit);
}
      readwaveparameters(afile, waves);
   end;
end;
(* end module getriblmatrix version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module putriblmatrix *)
procedure putriblmatrix(var afile: text;
                    matrix: ribltypeptr);
(* write the ribl matrix to afile. *)
var
   lindex: integer; (* index to Riblmatrix, equivalent to l *)
begin
   if matrix <> nil then begin
      with matrix^ do begin
         write(afile,'ribl');
         write(afile,' ');
         writequotestring(afile, riblname);
         writeln(afile);
         (* write the header *)
         writestringlines(afile, riblheader);
         writeln(afile, frombase: nfield,' ', tobase: nfield,' frombase, tobase');
         for lindex := frombase to tobase do begin
            write(afile,' ',
                       ' ',data[a, lindex]:infofield:infodecim,
                       ' ',data[c, lindex]:infofield:infodecim,
                       ' ',data[g, lindex]:infofield:infodecim,
                       ' ',data[t, lindex]:infofield:infodecim,
                       ' ',lindex:nfield);
            write(afile,' ',numbers[a,lindex]:nfield,
                        ' ',numbers[c,lindex]:nfield,
                        ' ',numbers[g,lindex]:nfield,
                        ' ',numbers[t,lindex]:nfield);
            writeln(afile);
         end;
         writeln(afile,'*');
         writeln(afile,mean:infofield:infodecim, 
                       ' bits = mean (Rsequence of selected region)');
         writeln(afile,stdev:infofield:infodecim,
                       ' bits = standard deviation');
         writeln(afile,'*');
         writeln(afile,consensus:infofield:infodecim,
                       ' bits = Ri of consensus sequence',
                       ' from ',frombase:1,' to ',tobase:1);
         writeln(afile,anticonsensus:infofield:infodecim,
                       ' bits = Ri of anticonsensus sequence',
                       ' from ',frombase:1,' to ',tobase:1);
         writeln(afile,'*');
         writeln(afile,averageRi:infofield:infodecim,
                       ' bits = average Ri for random sequence',
                       ' from ',frombase:1,' to ',tobase:1);
         writeln(afile,'*');
         writeln(afile,n:1,
                       ' n, number of sequences used to create the matrix');
         writeln(afile,'*');
         case symmetry of
           'a': write(afile, 'asymmetric');
           'e': write(afile, 'even');
           'o': write(afile, 'odd');
         end;
         writeln(afile, ' symmetry of the matrix');
         writeln(afile,'*');
         writeln(afile,Ribound:infofield:infodecim,
                       ' Ri bound: lower bound on Ri');
         writeln(afile,Zbound:infofield:infodecim,
                       ' Z bound: lower bound on Z');
         writeln(afile,Pbound:infofield:infodecim,
                       ' P bound: upper probability');
         writeln(afile,'*');
         writewaveparameters(afile, waves);
         writeln(afile);
      end
   end
end;
(* end module putriblmatrix *)

(* begin module writeadefinition *)
procedure writeadefinition(var afile: text; d: definitiontypeptr);
(* write the definition d to file afile *)
var i: integer; (* index to the string s *)
begin
   if d = nil then begin
      writeln(output,'writeadefinition was called with a nil definition!');
      halt;
   end;
   with d^ do begin
      write(afile,'define');
      write(afile,' '); writequotestring(afile,nametag);
      write(afile,' '); writequotestring(afile,background);
      write(afile,' '); writequotestring(afile,negparts);
      write(afile,' '); writequotestring(afile,posparts);
      for i := 1 to marks do write(afile,' ',locations[i]:1:1);
      writeln(afile);
{
      (* don't write the matrix this here - it's awkward if one wants
         to just write the parts above.  Just remember to write the
         matrix after the definition! *)
      writeln(afile);
      putriblmatrix(afile, matrix);
}
   end;
end;
(* end module writeadefinition version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module showadefinition *)
procedure showadefinition(var afile: text; d: definitiontypeptr);
(* show the definition d to file afile *)
const
   pwid = 8; (* width in character places to print PostScript numbers *)
   pdec = 5; (* decimal places to print PostScript numbers *)
var i: integer; (* index to the string s *)
begin
   writeln(afile,'DEFINITION: ');
   with d^ do begin
      write(afile,'nametag: ');
      writequotestring(afile,nametag);
      writeln(afile);

      write(afile,'background: ');
      writequotestring(afile,background);
      writeln(afile);

      write(afile,'negative parts: ');
      writequotestring(afile,negparts);
      writeln(afile);

      write(afile,'positive parts: ');
      writequotestring(afile,posparts);
      writeln(afile);

      write(afile,'locations: ');
      for i := 1 to marks do write(afile,' ',locations[i]:1:1);
      writeln(afile);

      writeln(afile,'marks: ',marks:1);
      writeln(afile,'min: ',min:5:1);
      writeln(afile,'max: ',max:5:1);

      write(afile,'petal: ');
      with petal do begin
         write(afile,el:1);
         write(afile,' ', c:1);
         write(afile,' ',eh:pwid:pdec);
         write(afile,' ',es:pwid:pdec);
         write(afile,' ',eb:pwid:pdec);
         write(afile,' ',fh:pwid:pdec);
         write(afile,' ',fs:pwid:pdec);
         write(afile,' ',fb:pwid:pdec);
         write(afile,' ',spare:pwid:pdec);
      end;
      writeln(afile);

{
      write(output,'THIS IS');
      if d^.istotal
      then writeln(output,      ' a total.')
      else if d^.isgap
           then writeln(output, ' a Gap.')
           else writeln(output, ' NEITHER a Gap nor a total.');
}
{sss}

   end;
end;
(* end module showadefinition version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module showdefinitions *)
procedure showdefinitions(var afile: text; definitionlist: definitiontypeptr);
(* show the definition in list definitionlist *)
var
   f: definitiontypeptr; (* current place in the definitionlist *)
begin
   f := definitionlist;
   while f <> nil do with f^ do begin
      showadefinition(afile, f);
      writeln(afile);
      f := f^.next;
   end;
end;
(* end module showdefinitions *)

(* begin module writedefinitions *)
procedure writedefinitions(var afile: text; definitionlist: definitiontypeptr);
(* write the definition in list definitionlist *)
var
   f: definitiontypeptr; (* current place in the definitionlist *)
begin
   f := definitionlist;
   while f <> nil do with f^ do begin
      writeadefinition(afile, f);
      f := f^.next;
   end;
end;
(* end module writedefinitions *)

(* begin module cleardefinition *)
procedure cleardefinition(var d: definitiontypeptr);
(* clear out the definition d *)
var
   l: integer; (* index to locations *)
begin
   with d^ do begin
      clearstring(nametag);
      clearstring(background);
      clearstring(negparts);
      clearstring(posparts);
      for l := 1 to maxstring do locations[l] := 0;
      marks := 0;
      min := 0.0;
      max := 0.0;
      definitionnumber := 0;
      matrix := nil;
      RiboundFeature := 0.0;
      ZboundFeature := 0.0;
      PboundFeature := 0.0;

      with petal do begin
         el := 0;
         c  := ' '; (* blank means NO PETAL *)
         eh := 0.0;
         es := 0.0;
         eb := 0.0;
         fh := 0.0;
         fs := 0.0;
         fb := 0.0;
         spare := 0.0;
      end;

      isgap := false;
      istotal := false;
      ismulti := false;
      next := nil;
   end
end;
(* end module cleardefinition *)

(* begin module equaldefinition *)
function equaldefinition(a,b: definitiontypeptr): boolean;
(* compare the definitions *)
var
   same: boolean; (* are the two definitions EXACTLY the same? *)
   i: integer; (* index to marks *)
begin
   same := true;
   if equalstring(a^.nametag,        b^.nametag) then begin
      if equalstring(a^.background,  b^.background) then begin
         if equalstring(a^.negparts, b^.negparts) then begin
{I'm not sure the next two are good to do: }
            if a^.min = b^.min then begin
               if a^.max = b^.max then begin
   (* definitely not to be compared:
   if a^.number = b^.number then begin
   *)
                  if a^.marks = b^.marks then begin
                     for i := 1 to a^.marks do begin
                        if a^.locations[i] <> b^.locations[i]
                        then same := false
                     end
                  end
               end
               else same := false
            end
            else same := false
         end
         else same := false
      end
      else same := false
   end
   else same := false;
   equaldefinition := same
{
      for i := 1 to marks do write(afile,' ',locations[i]:1:1);
not worth the time savings:
      i := 1;
      while same and (a^.locations[i] = b^.locations[i]) do begin
         i := i + 1
      end;
}
end;
(* end module equaldefinition *)
 
(* begin module readadefinition *)
procedure readadefinition(var afile: text; var d: definitiontypeptr);
(* read a single definition from afile *)
var
   i: integer; (* an index *)
   location: real; (* a location on the sequence *)

procedure IsGapOrIsTotal(var d: definitiontypeptr);
(* Is this a definition which is for a Gap or a total connecting
multi-walkers?  If so, set isgap or istotal true (respectively).  *)
const
   tab = 9; (* tab characters separate name parts *)
   debugging = false; (* use to debug the code *)
var
   totstring: string; (* the string that indicates a IsGapOrIsTotal total *)
   gapstring: string; (* the string that indicates a IsGapOrIsTotal gap *)
   deflocation: integer; (* location in the nametag *)
   gaplocation: integer; (* location in the gapstring *)
   totlocation: integer; (* location in the total *)
   done: boolean; (* done comparing strings *)
begin

if debugging then begin
  writeln(output,'IsGapOrIsTotal test of this definition:'); {sss}
  writeadefinition(output,d); {sss}
end;

   clearstring(totstring);
   with totstring do begin
      letters[1] := chr(tab);
      letters[2] := 't';
      letters[3] := 'o';
      letters[4] := 't';
      letters[5] := 'a';
      letters[6] := 'l';
      length := 6;
   end;

   clearstring(gapstring);
   with gapstring do begin
      letters[1] := chr(tab);
      letters[2] := 'G';
      letters[3] := 'a';
      letters[4] := 'p';
      length := 4;
   end;

{
writeln(output, 'IsGapOrIsTotal: begin &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&');
}

   (* search for the Gap string *)
   done := false;
   d^.isgap := true;
   deflocation := d^.nametag.length;
   gaplocation := gapstring.length;
   while not done do begin
{
write(output,
'====>',
d^.nametag.letters[deflocation],
gapstring.letters[gaplocation]);
}
      if d^.nametag.letters[deflocation] <> gapstring.letters[gaplocation]
      then begin
         d^.isgap := false;
         done := true
      end;
      deflocation := deflocation - 1;
      gaplocation := gaplocation - 1;
{
write  (output,' deflocation = ',deflocation:1);
writeln(output,' gaplocation = ',gaplocation:1);
}
      if deflocation < 1 then done := true;
      if gaplocation < 1 then done := true;
   end;

(* just for debugging:
   if d^.isgap then begin
      if debugging then write(output, 'gap:   ');
      write(output, '====================');
      writestring(output, d^.nametag);
      writeln(output, '=======');
      writeadefinition(output, d);
      writeln(output);
      writeln(output, '====================');
{ok pointing to the features of this
has to happen with each feature of this type }
{      d^.isgap := true why set this???}
   end
   else begin
{
      if debugging then write(output, '       ');
      writestring(output, d^.nametag);
      writeln(output);
}
{      d^.isgap := false why set this???}
   end;
*)

   (* search for the total string *)
   d^.istotal := true;
   done := false;
   (* skip to the tab before the bits *)
   deflocation := d^.nametag.length;
   while not done do begin
{
write(output,d^.nametag.letters[deflocation]);
}
      if d^.nametag.letters[deflocation] = chr(tab)
      then done := true;
      deflocation := deflocation - 1;
      if deflocation < 1 then begin
         done := true;
         d^.istotal := false; (* fell off begin of string *)
      end;
   end;
{
writeln(output,'<-PRETOTAL');
}
   if d^.istotal = true then begin (* it still might be true *)
{
writeln(output,'...');
}
      totlocation := totstring.length;
      done := false;
{
this is defined above!
      deflocation := d^.nametag.length;
}
      while not done do begin
{
write(output,
'====>',
d^.nametag.letters[deflocation],
totstring.letters[totlocation]);
}
         if  d^.nametag.letters[deflocation]
         <> totstring.letters[totlocation]
         then begin
            d^.istotal := false;
            done := true
         end;
         deflocation := deflocation - 1;
         totlocation := totlocation - 1;
{
write  (output,' deflocation = ',deflocation:1);
writeln(output,' totlocation = ',totlocation:1);
}
         if deflocation < 1 then done := true;
         if totlocation < 1 then done := true;
      end;
   end;

   (* mark that this definition is part of a multiple set *)
   if d^.isgap or d^.istotal
   then d^.ismulti := true
   else d^.ismulti := false;

   if debugging then begin
{sss}
{
      writeadefinition(output, d);
}
      showadefinition(output, d);
{
if d^.istotal then begin
writeln(output, 'IsGapOrIsTotal: is total');
halt;
end;
}
      if d^.isgap
      then writeln(output,'Is a gap')
      else writeln(output,'Is NOT a gap');
      if d^.istotal
      then writeln(output,'Is a total')
      else writeln(output,'Is NOT a total');
      writeln(output, 'IsGapOrIsTotal: end &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&');
   end;

end; (* IsGapOrIsTotal *)

begin (* readadefinition *)
{writeln(output,'readadefinition');}
   skipnonblanks(afile);
   skipblanks(afile);
   with d^ do begin
      readquotestring(afile, nametag);

      (* read background character from a quotestring *)
      readquotestring(afile,background);
      if (background.length < 1) or
         (background.length > 2) then begin
         writeln(output,'Background string must contain only 1 or 2',
                        ' characters.');
         write(output,'Instead, it contained: ');
         writequotestring(output,background);
         writeln(output);
         halt
      end;

      readquotestring(afile,negparts);
      readquotestring(afile,posparts);
      if negparts.length <> posparts.length then begin
         write(output,'While reading definition of ');
         writequotestring(output,nametag);
         writeln(output);
         write(output,'the negative part ');
         writequotestring(output,negparts);
         writeln(output,' and');
         write(output,'the positive part ');
         writequotestring(output,posparts);
         writeln(output,' are not the same length.');
         writeln(output,'(',negparts.length:1,'<>',posparts.length:1,')');
         halt
      end;

      marks := negparts.length;
      if marks = 0 then begin
         (* multiscan uses empty strings sometimes ... *)
         marks := 2
      end;

      for i := 1 to marks do read(afile,locations[i]);

      matrix := nil;
      RiboundFeature := -maxint;
      ZboundFeature := +maxint;
      PboundFeature := 0.0;

      ismulti := false;

      next := nil;

      (* checks *)

      (* now compute the absolute coordinates that the feature resides in *)
      min := +maxint;
      max := -maxint;
      for i := 1 to marks do begin
         location := locations[i];
         if location < min then min := location;
         if location > max then max := location;
      end;
      if min = +maxint then begin
         writeln(output,'readadefinition: program error at min');
         halt
      end;
      if max = -maxint then begin
         writeln(output,'readadefinition: program error at max');
         halt
      end;

      (* determine if this is a Gap or total type feature *)
      IsGapOrIsTotal(d);

   end;
{
writeln(output,'-----');
showadefinition(list,d);
writeln(output,'-----');
}
end;
(* end module readadefinition version = 11.64; (@ of lister.p 2006 Oct 10 *)

(* begin module clearfeature *)
procedure clearfeature(var f: featuretypeptr);
(* clear out the feature f *)
begin
   with f^ do begin
      clearstring(id);
      coordinate := 0;
      orientation := +1;
      clearstring(nametag);
      clearstring(othertag);
      definition := nil;
      duplicateprevious := nil;
      Ri := 0.0;
      Z := 0.0;
      probability := 0.0;
      Tparam := ' ';
      Aparam := 0.0;
      Bparam := 0.0;
      Cparam := 0.0;
      Dparam := 0.0;
      relcoo := 0.0;
      evencoordinate := 0.0;
      unsatisfied := true;
      fromrange := 0;
      torange := 0;
      featurenumber := 0;
      featuregroup := 0;
      featureisfirstingroup := false;
      desiredline := 0;
      others := nil;
      mothers := nil;
      usedInGroup := false; (* used in group *)
      next := nil;
   end
end;
(* end module clearfeature version = 13.33; (@ of lister.p 2017 Feb 14 *)

(* begin module writeafeature *)
procedure writeafeature(var afile: text; f: featuretypeptr);
(* write the feature f to file afile in the format:
@ K00000 36 +1 "nametag" "othertag" 12.200338 -0.473212 0.318031 -26
where the last three numbers are the Ri, Z and p
followed by the relative coordinate [2016 aug 18].
Do not carriage return.
*)
var
   o: featurecarrierptr; (* other or mother features that this one
      points to *)
begin
{writeln(output, '======> writeafeature zwwww');}
   if f = nil then begin
      writeln(output, 'writeafeature: nil feature pointer!');
      halt;
   end;
   with f^ do begin
      write(afile,'@ ');
      writeNOTABstring(afile,id);
      write(afile,' ',coordinate:1:1);
      write(afile,' ');
      if orientation > 0 then write(afile,'+',orientation:1)
                         else write(afile,    orientation:1);
      write(afile,' ');
      writequotestring(afile,nametag);
      write(afile,' ');
      writequotestring(afile,othertag);
{write(output, '[======> writeafeature zwwww did othertag]');}
      if definition = nil then begin
{
         writeln(output); (* break away from the previous line *)
         writeln(output, 'writeafeature: nil definition pointer');
         writeln(output, 'for feature:');
         writeNOTABstring(output,id);
         write(output,' ');
         writequotestring(output,nametag);
         write(output,' ');
         writequotestring(output,othertag);
         writeln(output);
}
         write(afile,' ',0.0:infofield:infodecim);
         write(afile,' ',0.0:infofield:infodecim);
         write(afile,' ',0.0:infofield:infodecim);
         write(afile,' ',0.0:3:1); (* relative coordinate *)
      end
      else begin
         if definition^.matrix <> nil then begin
{
            write(afile,' ',Ri:infofield:infodecim);
            write(afile,' ',Z:infofield:infodecim);
            write(afile,' ',probability:infofield:infodecim);
}
{write(output, '[======> writeafeature zwwww about to Ri]');}
            write(afile,' ',Ri:1:infodecim);
            write(afile,' ',Z:1:infodecim);
            write(afile,' ',probability:1:infodecim);
         end
         else begin (* parameters, new as of 2004 July 17 *)
            write(afile,' ',Tparam);
{
            write(afile,' ',Aparam:infofield:infodecim);
            write(afile,' ',Bparam:infofield:infodecim);
            write(afile,' ',Cparam:infofield:infodecim);
            write(afile,' ',Dparam:infofield:infodecim);
}
{write(output, '[======> writeafeature zwwww about to Aparam]');}
            write(afile,' ',Aparam:1:infodecim);
{write(output, '[======> writeafeature zwwww about to Bparam]');}
            write(afile,' ',Bparam:1:infodecim);
            write(afile,' ',Cparam:1:infodecim);
            write(afile,' ',Dparam:1:infodecim);
         end;
         write(afile,' ',relcoo:1:1); (* relative coordinate *)
{zzzqqq}
         write(afile,' #',featurenumber:1); (* feature number *)
         write(afile,' in group ',featuregroup:1); (* feature group *)
      end;
      if others <> nil then begin
         if others^.afeature <> nil then write(afile,' > ');
         o := others;
         while o <> nil do begin
            if o <> others then write(afile,', ');
            if o^.afeature <> nil then begin
               write(afile,'[');
               writeNOTABstring(afile,o^.afeature^.nametag);
               write(afile,']');
            end;
            o := o^.next;
         end;
      end;
   end
end;
(* originally from 9.29; (@ of lister.p 1999 July 5 *)
(* end module writeafeature version = 13.33; (@ of lister.p 2017 Feb 14 *)

(* begin module readafeature *)
procedure readafeature(var afile: text;
                           definitionlist: definitiontypeptr;
                       var f: featuretypeptr);
(* Read a single feature from afile.  It has to match one of the
definitions in definitionlist.  The LAST definition read so far is the
one used for this feature, not any previous ones.
No carriage return is performed; this allows comments at the end of
the feature.
*)
var
   d: definitiontypeptr; (* current place in the definitionlist *)
procedure reportandhalt;
(* report a bad feature and halt *)
begin
   writeln(output, 'Feature details:');
   writeafeature(output, f);
   writeln(output);
   halt;
end;
begin
{writeln(output,'readafeature');}
   with f^ do begin
      skipnonblanks(afile);
      skipblanks(afile);
      grabtoken(afile, id);
      read(afile,coordinate);
      read(afile,orientation);
      readquotestring(afile,nametag);
      readquotestring(afile,f^.othertag);

      (* checks *)
      if not ((orientation = -1) or (orientation = +1)) then begin
         write(output,'while reading feature id ');
         writequotestring(output,id);
         writeln(output);
         writeln(output, 'feature orientation must be -1 or +1');
         writeln(output, 'It is ',orientation:1);
         reportandhalt
      end;

      (* Use the last definition read in before this feature *)
      (* 2008 Aug 06 *)
      d := definitionlist;
      while d <> nil do begin
         if equalstring(d^.nametag, f^.nametag) then begin
            definition := d;
         end;
         d := d^.next
      end;
      if definition = nil then begin
         write(output, 'No definition was found for feature ');
         writequotestring(output,nametag);
         writeln(output);
         reportandhalt
      end;
      d := definition;

      (* now we can read in the Ri, Z and probability *)
      if d^.matrix <> nil
      then begin
         read(afile, Ri, Z, probability);
         if not eoln(afile)
         then read(afile,relcoo) (* 2016aug19: new parameter *)
         else relcoo := 0.0; (* protect for reading old features *)
      end
      else begin
         (* give values that allow the site to always be found *)
         Ri := -maxint;
         Z  := maxint;
         probability := 1.0;
         (* read parameters for feature: *)

         (* To keep the previously defined features stable,
            read T param here by first making sure that the
            next object is not a number. *)

         skipblanks(afile);
         if eoln(afile) then begin (* handle blank line *)
            Tparam := ' ';
            Aparam := 0.0;
            Bparam := 0.0;
            Cparam := 0.0;
            Dparam := 0.0;
            relcoo  := 0.0;
         end
         else begin
            if (afile^ in
               ['-','+','0','1','2','3','4','5','6','7','8','9'])
            then begin
               (* Old style, just read it in *)
               read(afile, Aparam);
               read(afile, Bparam);
               read(afile, Cparam);
               Dparam := 0;
            end
            else begin
               read(afile, Tparam);
               read(afile, Aparam);
               read(afile, Bparam);
               read(afile, Cparam);
               read(afile, Dparam);
           end;
           if not eoln(afile)
           then read(afile,relcoo) (* 2016aug19: new parameter *)
           else relcoo := 0.0; (* protect for reading old features *)
        end;
      end;

(* 2004 July 17: I went ahead and removed this.  As far as I know
it is NOT used in feature files:
      if not eoln(afile) then read(afile, evencoordinate)
                         else evencoordinate := coordinate;
*)

      unsatisfied := true;
      fromrange := definition^.min;
        torange := definition^.max;

{
      featurenumber := globalfeaturenumber; (* number assigned *)
}
      desiredline := 0; (* initially it can go on any line *)
      next := nil; (* it is not connected to anything yet *)

      (*
      others:  featurecarrierptr; (@ other features this feature points to! @)
      mothers: featurecarrierptr; (@ The features that point to this feature @)
      *)
      others := nil;
      mothers := nil;

   end
end;
(* originally from 9.29; (@ of lister.p 1999 July 5 *)
(* end module readafeature version = 13.33; (@ of lister.p 2017 Feb 14 *)

(* begin module showafeature *)
procedure showafeature(var afile: text; f: featuretypeptr);
(* show the feature f to file afile *)
var
   o: featurecarrierptr; (* other features that this one points to *)
   totals: integer; (* totals pointing to f *)
   gaps: integer; (* gaps pointing to f *)
begin
   totals := 0;
   gaps := 0;
   with f^ do begin
      write(afile,'FEATURE #', featurenumber:1,
                  ' in group ',featuregroup:1);
{zzzfff}
      if featureisfirstingroup
      then write(afile,', FIRST in this group')
      else begin
         write(afile,', NOT FIRST in this group');
         if f^.definition^.istotal
         then write(afile,', TOTAL = end of this group')
         else write(afile,', MIDDLE feature');
      end;
      writeln(afile);
      write(afile,'id: ');
      writequotestring(afile,id);
      writeln(afile);

      writeln(afile,'coordinate: ',coordinate:1:1);

      write(afile,'orientation: ');
      if orientation > 0 then writeln(afile,'+',orientation:1)
                         else writeln(afile,    orientation:1);

      write(afile,'nametag: ');
      writequotestring(afile,nametag);
      writeln(afile);

      write(afile,'othertag: ');
      writequotestring(afile,othertag);
      writeln(afile);

      write(afile,'unsatisfied: ');
      if unsatisfied then writeln(afile,'true')
                     else writeln(afile,'false');

      writeln(afile,'fromrange: ',fromrange:5:1);
      writeln(afile,'  torange: ',  torange:5:1);
      writeln(afile,'desiredline: ',  desiredline:5);
      if duplicateprevious = nil
      then writeln(afile,'NOT a duplicate feature')
      else writeln(afile,'DUPLICATE of feature #',
                   duplicateprevious^.featurenumber:1);

      if others <> nil then begin
         writeln(afile,'This feature points at these OTHERS:');
         write(afile,'feature #',featurenumber:1,' -> ');
         o := others;
         while o <> nil do begin
{
write(afile,'-LOOP-');
if o = others then write(afile, '|o = others');
if o <> others then write(afile, '|o <> others');
if not (o = others) then write(afile, '|not (o = others)');
write(afile, '|');
}
{KKKKK}
            if o <> others then write(afile,', ');
            if o^.afeature <> nil then begin
               write(afile,'[');
               writeNOTABstring(afile,o^.afeature^.nametag);
               write(afile,']');
            end
            else write(afile,'[EMPTY]');
            o := o^.next;
         end;
         writeln(afile);
         o := others;
         while o <> nil do begin
            if o^.afeature <> nil then begin
               write(afile,'= ');
               writeafeature(afile,o^.afeature);
               writeln(afile);
            end;
            o := o^.next;
         end;
      end
      else begin
         writeln(afile,'This feature does not point to any OTHERS.');
      end;

      if mothers <> nil then begin
         writeln(afile,'The MOTHERS of this feature', 
                       ' (that point to this feature) are:');
         o := mothers;
         while o <> nil do begin
            if o^.afeature <> nil then begin
               write(afile,'feature #',featurenumber:1,' <- "');
               writeNOTABstring(afile,o^.afeature^.nametag);
               writeln(afile,'" #',o^.afeature^.featurenumber:1);
{
               writeln(afile,'"');
}
               if o^.afeature^.definition^.istotal
               then totals := succ(totals);
               if o^.afeature^.definition^.isgap
               then gaps := succ(gaps);
            end;
{writeln(output,'BUBBA: mothers part 1 about to "o := o^.next;" ');}
            o := o^.next;
         end;
         o := mothers;
{writeln(output,'BUBBA: mothers part 1 is done');}
         while o <> nil do begin
            if o^.afeature <> nil then begin
               write(afile,'= ');
               writeafeature(afile,o^.afeature);
               writeln(afile);
            end;
            o := o^.next;
         end;
{writeln(output,'BUBBA: mothers part 2 is done');}
      end
      else begin
         writeln(afile,'This feature has no MOTHERS.');
      end;
{writeln(output,'BUBBA: showafeature is done');}

   end;
   write(afile,gaps:1,' gap');
   if gaps <> 1 then write(afile,'s'); (* stolen from plural *)
   writeln(afile);
   write(afile,totals:1,' total');
   if totals <> 1 then write(afile,'s'); (* stolen from plural *)
   writeln(afile);
   if (totals > 1) then begin
      writeln(output,'showafeature: more than one total!');
      halt;
   end;
   if (gaps >1) and (totals < 1) then begin
      writeln(output,'showafeature: ',gaps:1,' gaps but no total!');
{NNN}
      halt;
   end;
end;
(* end module showafeature version = 13.33; (@ of lister.p 2017 Feb 14 *)

(* begin module showfeatures *)
procedure showfeatures(var afile: text; featurelist: featuretypeptr;
                       paging: boolean);
(* Show all of the features in list featurelist.
If paging is true, page between the features
*)
var
   f: featuretypeptr; (* current place in the featurelist *)
begin
   f := featurelist;
   while f <> nil do with f^ do begin
      showafeature(afile, f);
      f := f^.next;
      if f <> nil then begin
         (* don't add spacing or page for the last one! *)
         if paging
         then page(afile)
         else writeln(afile);
      end;
   end;
end;
(* end module showfeatures version = 13.33; (@ of lister.p 2017 Feb 14 *)

(* begin module writefeatures *)
procedure writefeatures(var afile: text; featurelist: featuretypeptr);
(* write the features in list featurelist *)
var
   f: featuretypeptr; (* current place in the featurelist *)
begin
   f := featurelist;
   while f <> nil do with f^ do begin
      writeafeature(afile, f);
      writeln(afile);
      f := f^.next;
   end;
end;
(* end module writefeatures *)

(* begin module featureinlist *)
function featureinlist(featurelist: featuretypeptr;
                        newfeature: featuretypeptr;
                    var oldfeature: featuretypeptr): boolean;
(* determine if the new feature is found in the feature list.
If it was found, report the location in oldfeature.
Note that this is a SIDE EFFECT. *)
{2007 Mar 26 ppp}
var
   f: featuretypeptr; (* a feature in featurelist *)
{
   test: featuretype; (* a test feature.  We use this to
      avoid modifying newfeature *)
}
   done: boolean; (* done searching? *)
   found: boolean; (* the feature matches *)
procedure checkorpos;
(* check the orientation and position *)
begin
{
writeln(output,'checkorpos');
}
   found :=
      (newfeature^.orientation = f^.orientation)
         and
      (newfeature^.coordinate = f^.coordinate)
end; (* checkorpos *)
begin

{ just some checks for debugging
writeln(output);
writeln(output,'----------------------------------------------------');
showfeatures(output, featurelist, true);
writeln(output,'--------');
write(output,'new: ');
writeafeature(output,newfeature);
writeln(output);
}

   done := false;
   found := false;
   f := featurelist;
   oldfeature := nil;
{
write(output,'newfeature: ');
writeafeature(output,newfeature);
writeln(output);
}
   while not done do begin

{
write(output,'CHECK:   f: ');
writeafeature(output,f);
writeln(output);
}

      if equalstring(newfeature^.id, f^.id) and
         equalstring(newfeature^.nametag, f^.nametag)
      then if f^.definition = nil
         then checkorpos
         else if f^.definition^.matrix = nil
              then checkorpos
              else found :=

         (* Be paranoid about losing a walker!!
            They have to be the same evaluation: *)
         (newfeature^.Ri = f^.Ri) and
{
this would be overkill that probably would'nt help:
 and
         (newfeature^.Z = f^.Z) and
         (newfeature^.probability = f^.probability) and
}

         (* all three cases of matrix symmetry must be considered. *)

         (

           (* an odd symmetry will always match. *)
           (
             (f^.definition^.matrix^.symmetry = 'o')
               and
             (newfeature^.coordinate = f^.coordinate)
           )

           or

           (* an asymmetric symmetry will only match with = orientation. *)
           (
             (f^.definition^.matrix^.symmetry = 'a')
             and
             (newfeature^.orientation = f^.orientation)
             and
             (newfeature^.coordinate = f^.coordinate)
           )

           or
(* it doesn't seem possible to use the evencoordinate variable here!
Let it hang around though just in case.  The difficulty is that
at a coordinate jump evencoordinate will be different on the two sides.
*)

           (* an even symmetry will only match if one base away. *)
           (* THIS WILL FAIL AT A COORDINATE JUMP.  (fortunately rarely) *)
           (
             (f^.definition^.matrix^.symmetry = 'e')
             and
             (1 = abs(newfeature^.coordinate - f^.coordinate))
             and
             (newfeature^.orientation <> f^.orientation)
           )

           or

           (* an even symmetry will also match if identical. *)
           (
             (f^.definition^.matrix^.symmetry = 'e')
             and
             (newfeature^.coordinate = f^.coordinate)
             and
             (newfeature^.orientation = f^.orientation)
           )

         );

      if found then begin
         oldfeature := f;
         done := true;
{
;

write(output,'newfeature: ');
writeafeature(output,newfeature);
writeln(output);
write(output,'         f: ');
writeafeature(output,f);
writeln(output);

}
      end
      else if f^.next = nil
           then begin
              done := true;
              found := false
           end
           else f := f^.next
   end;
{
if found then
then writeln(output,'featureinlist: found = trew blew')
else writeln(output,'featureinlist: found = falseto');
}
   featureinlist := found
end;
(* end module featureinlist version = 13.33; (@ of lister.p 2017 Feb 14 *)

(* begin module locatedefinition *)
procedure locatedefinition(aname: string;
                           definitionlist: definitiontypeptr;
                           var thedefinition: definitiontypeptr);
(* locate the definition corresponding to aname
in the definitionlist. *)
var
   done: boolean; (* are we done searching for the definition? *)
begin
   thedefinition := definitionlist;
   done := false;
   repeat
      if thedefinition = nil
      then done := true
      else begin
         (* is it the one we want? *)
         if equalstring(thedefinition^.nametag, aname)
         then done := true
         else thedefinition := thedefinition^.next
      end
   until done;
end;
(* end module locatedefinition version = 13.33; (@ of lister.p 2017 Feb 14 *)

(* begin module locatefeature *)
procedure locatefeature(aname: string;
                        coo: real;
                        featurelist: featuretypeptr;
                        var thefeature: featuretypeptr;
                        StopAtTotal: boolean);

(* locate the feature corresponding to aname and coordinate coo in the
featurelist.  If the feature is found, it is pointed to by thefeature.
If it is not found, thefeature is nil.  If StopAtTotal is true, stop
when the first total feature is found.  This is used to confine the
search to a particular cluster of mutipart features.  Note that the
appropriate start point (ie, featurelist) must be determined by the
callig routines to begin at the start of the cluster. *)
var
   done: boolean; (* are we done searching for the feature? *)
begin
   thefeature := featurelist;
   done := false;
   repeat
      if thefeature = nil
      then done := true
      else begin
         (* is it the one we want? *)
   {
write(output,'locatefeature: thefeature^.nametag = ');
writequotestring(output,thefeature^.nametag);
write(output,' thefeature^.coordinate =', thefeature^.coordinate:1:1);
write(output,' coo =', coo:1:1);
writeln(output);
   }
         if equalstring(thefeature^.nametag, aname)
         then begin
            if thefeature^.coordinate = coo
            then done := true
            else thefeature := thefeature^.next
         end
         else if thefeature^.definition^.istotal and StopAtTotal   
         then begin
             (* we found the total and not the feature *)
             thefeature := nil
         end
         else thefeature := thefeature^.next
      end
   until done;
end;
{mmm}
(* end module locatefeature version = 12.02; (@ of lister.p 2007 Apr 02 *)

(* begin module readdefinitionsandfeatures *)
procedure readdefinitionsandfeatures(var afile: text;
                       var KeepDuplicates: boolean;
{zzzccc}
                       var comments: stringptr;
                       var definitionlist: definitiontypeptr;
                       var featurelist: featuretypeptr;
                       var groupnumber: integer);
(* Read definitions and features from afile.
These are defined in the lister.p program.
Keep duplicate features if KeepDuplicates is true.

The objects in the afile are identifiers.
The first character of lines in afile defines the identifier.
The legal identifier values are:

* comment
d definition of a feature
r ribl matrix
b boundary for site
c color rectangle
@ location of a feature
g beginning of a group that has gap connection lines and ends with a total line

2007 Mar 20.  One of the important tasks of readdefinitionsandfeatures
is to string together the features of multi-part features coming from
multiscan.  Traditionally this was done by searching for the related
parts while the list was being read and through all previously read
features.  However, this tends to lead to confusion in very complex
genetic structures where several sites of even the same kind can be in
the same position.  To avoid this the program (version 11.90 and on)
now keeps track of a new variable, cluster, which is a pointer into
the featurelist.  As each cluster is found, searches to find the parts
in markismulti are restricted to the cluster.  Also, all the threading
is done AFTER the features are read in, simplifying the process.
222

2007 Mar 26. The problem with actually removing duplicate features
from the featurelist is that the threading of mothers and others
fails.  The solution is to KEEP all duplicates, but to flag duplicates
(if KeepDuplicates is true) and then later to simply not count them
when displaying the results.

2016 Aug 12.  The problem with the above method is that it
relies on external coordinates to locate features.  This can
fail when going across coordinate bound of a circular piece.
New (tentative) method is to mark the multipart groups
explicitly with a 'group' line and then the threading should
just join the parts directly instead of clustering later.

2016 Sep 06: I removed all the code for markismulti

*)
var
   aname: string; (* a name of the ribl feature being read in *)
   commentparts: stringptr; (* comment parts *)
   countdefinitions: integer; (* count of the definitions read in *)
   countfeatures: integer; (* count of the features read in *)
   countribls: integer; (* count of the ribls read in *)
   countboundaries: integer; (* count of the boundaries read in *)
   countpetals: integer; (* count of the color rects read in *)
   currentcomment: stringptr; (* pointer to the currently read comment *)
   d: definitiontypeptr; (* current place in the definitionlist *)
   done: boolean; (* are we done searching for the definition? *)
   dprevious: definitiontypeptr; (* place in the definitionlist prior to d *)
   dtest: definitiontypeptr; (* place in the definitionlist for testing *)
   emptyafile: boolean; (* true if the afile is empty *)
   f: featuretypeptr; (* current place in the featurelist *)
   firstfeature: boolean; (* first feature of a feature list must be
                             read properly *)

(*gggGGG*)
   (* Group definitions 2016 Aug 12
      These variables are used to thread together a group of
      features and definitions with the total line.
      Most could be moved to procedure threadgroup.
    *)
   groupnumberinfile: integer; (* the group number read from the file *)
   mycharacter: char; (* for reading past the word 'group' in afile *)
   firstfeatureofgroup: boolean; (* for identifying the first feature
      of a group [this is not the firstfeature of a feature list!] *)
   ingroup: boolean; (* we are inside a group within the featurelist
      linked list of features *)
   groupfeature: featuretypeptr; (* the start of a group feature *)
   aGapFeature: featuretypeptr; (* the location of a gap feature *)
   groupTotalFeature: featuretypeptr; (* the location of the total feature *)
   groupGapCarrier: featurecarrierptr; (* the end of the Gap list *)
   groupTotalCarrier: featurecarrierptr; (* the end of the Total list *)
   leftgap:  featuretypeptr; (* left  side of a gap *)
   rightgap: featuretypeptr; (* right side of a gap *)
   ff: featuretypeptr; (* current place in the featurelist after the groupfeature:
                          then the feature we need to thread *)
   gg: featuretypeptr; (* current place in the featurelist after the groupfeature:
                          then the group we need to thread *)
   nameparts: stringptr; (* name parts of a total string *)
   anamepart: stringptr; (* one name in a total string *)
   leftstring  : string; (* left side of gap string *)
   gapstring   : string; (* middle gap string *)
   rightstring : string; (* right side of gap string *)
   gap: integer; (* gapstring converted to a number *)
   aletter: char; (* a letter in the gapstring *)

   identifier: char; (* identify the data type in afile *)
   matrix: ribltypeptr; (* ribl matrix being read in *)
   missingmatrix: boolean; (* has the matrix for a definition been read in? *)
   newfeature: featuretypeptr; (* a new feature.  If it is unique,
      we will add it to the f list. *)
   oldfeature: featuretypeptr; (* a feature that matches the newfeature *)
   thedefinition: definitiontypeptr; (* index to locate the definition
      corresponding to a ribl feature read in. *)
   uniquedefinitions: integer; (* count of the unique definitions read in *)
   uniquefeatures: integer; (* count of the unique features read in *)
procedure yell;
(* tell the user something is wrong and who we are *)
begin
   writeln(output,'ERROR in reading definitions and features');
end;

procedure barout;
(* just write a bar for warnings *)
begin
writeln(output, '***********************************',
                '***********************************');
end;

procedure splitstring(s: string; break, terminator: char;
                      var parts: stringptr);
(* split the string s by the break characters up to the terminator
character.  The resulting parts are linked strings.  This is for
use in splitting the total nametag into its parts.  Example:
"distal-proximal-p35-p10	4164377	total	15.0"
becomes:
"distal"
"proximal"
"p35"
"p10"
*)
const
   debugSplitstring = true; (* set to true to debug *)
{TTT}
var
   l: integer; (* location in the string s *)
   done: boolean; (* done finding parts *)
   spointer: stringptr; (* pointer to the string *)
begin
if superdebug then begin
if debugSplitstring then begin
writeln(output,'IN splitstring the string to split is:');
write(output,'"');
writestring(output,s);
writeln(output,'"');
writeln(output,'======> break character is: "',break,'"');
end;
end;
   l := 1;
   done := false;
   disposestring(parts); (* clear out any previous parts *)
   new(parts);
   spointer := parts;
   clearstring(spointer^);
   while not done do begin
      if s.letters[l] = terminator then done := true
      else begin
         if s.letters[l] = break then begin
if superdebug then begin
if debugSplitstring then begin
write(output,'debugSplitstring: "');
writestring(output,spointer^);
writeln(output,'"');
end;
end;
            new(spointer^.next);
            spointer := spointer^.next;
            clearstring(spointer^); {TTT}
         end
         else begin
            spointer^.length := spointer^.length + 1;
            spointer^.letters[spointer^.length] := s.letters[l];
if superdebug then begin
if debugSplitstring then begin
if (s.letters[l] = ' ') then begin
writeln(output,'debugSplitstring: splitstring write a space $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$');
end;
if (s.letters[l] = chr(9)) then begin
writeln(output,'debugSplitstring: splitstring write a TAB  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$');
end;
if false then (* silence the verbose stuff for now *)
writeln(output,'WRITING: ord(', s.letters[l],')=', ord(s.letters[l]):1);
end;
end;
         end;
         l := succ(l);
         if l > maxstring then done := true
      end;
      if l = maxstring then begin
         writeln(output,'splitstring: maxed out! maxstring = l = ',l:1);
         halt;
      end;
   end;
if superdebug then begin
if debugSplitstring then begin
write(output,'debugSplitstring: splitstring result: "'); 
writestring(output,spointer^);
writeln(output,'"');
writeln(output,'OUT splitstring');
end;
end;
end; (* splitstring *)

procedure threadgroup;
(* Thread the current feature f and other features into a group - if
we find that we are at the end of the group. *)
var
   m: integer; (* index to marks of a total feature *)

(*-----*)
procedure countmarks(f:featuretypeptr; requiredcount: integer);
(* Count the others in feature f.
If the observed number is not the expected number (expectedcount),
then something is very wrong!
If requiredcount is -1, then the expected count is
the number of marks in the total.  Otherwise requiredcount is
the count expected.
*)
const
   countmarkdebug = false; (* display extra information when called *)
var
   expectedcount: integer; (* expected number of others *)
   observedcount: integer; (* count of others in a total feature *)
   otherptr: featurecarrierptr; (* location of an other *)
procedure countmarksprint; (* print the feature information *)
begin
   write(output,'++++++++ countmarks ++++++++');
   if requiredcount < 0
   then writeln(output,' final check')
   else writeln(output,' looking for ',requiredcount:1, ' marks');
   writeln(output,'++++++++ Counting marks for this total feature',
                  ' in group number: ',groupnumber:1,
                  ' FAILED: ');
   showadefinition(output,f^.definition);
   {writeafeature(output,f); writeln(output);}
   showafeature(output,f);
   writeln(output,f^.definition^.marks:1, ' marks are in this feature');

if false then begin (* final display for debugging *)
writeln(output);
writeln(output,'******* countmarks readdefinitionsandfeatures: *******');
writeln(output,'******* DEFINITIONS:');
if false then showdefinitions(output,definitionlist);
writeln(output);
writeln(output,'******* FEATURES:');
if true then showfeatures(output,featurelist, true);
writeln(output);
writeln(output,'******* countmarks readdefinitionsandfeatures: *******'); {sss}
{
halt;
}
end;

end; (* countmarksprint *)
begin
if countmarkdebug then writeln(output,'+++++++++++++++++++++ BEGIN countmarks');
   if (f^.definition^.istotal) then begin
      if f^.others <> nil then begin
         otherptr := f^.others;
         observedcount := 0;
         while otherptr <> nil do begin
if countmarkdebug then begin
writeln(output);
writeafeature(output,otherptr^.afeature);writeln(output);
writeln(output,'loop observedcount=',observedcount:1);
writeln(output,'isgap:   ',otherptr^.afeature^.definition^.isgap);
writeln(output,'istotal: ',otherptr^.afeature^.definition^.istotal);
end;
               if     (not otherptr^.afeature^.definition^.isgap)
                  and (not otherptr^.afeature^.definition^.istotal)
               then begin
                  observedcount := succ(observedcount);
               end;
            otherptr := otherptr^.next;
         end;
if countmarkdebug then writeln(output,'**** final observedcount=',observedcount:1);
{FFF}
         if requiredcount = -1
         then expectedcount := f^.definition^.marks
         else expectedcount := requiredcount;
         if observedcount <> expectedcount then begin
{fff}
            countmarksprint;
            writeln(output,'countmarks:',
                           ' expected: ', expectedcount:1,
                           ' observed: ', observedcount:1);
            writeln(output,'**** Wrong number of marks found',
                           '  in linked list for this total feature. ****');
            halt;
         end;
      end
      else begin
         if countmarkdebug then writeln(output,'countmarks no others');
      end
   end
   else begin
      writeln(output,'countmarks feature is not a total, cannot count marks');
      halt;
   end;
if countmarkdebug then writeln(output,'+++++++++++++++++++++ END countmarks');
end; (* countmarks *)
(*-----*)

procedure addmotherlinks(var agap: featuretypeptr;
                         var thefeature: featuretypeptr);
(* Thread the gap feature agap into the feature's mother list.
Don't add it if it is already in the list. *)
var
   mom: featurecarrierptr; (* pointer into the thefeature's mother list *)
   previousMom: featurecarrierptr; (* the previous p to allow adding
      to the end of the linked list *)
   gapthing: featurecarrierptr; (* holder for the new carrier *)
   done: boolean; (* done adding to the list *)
begin
{iii}
{
writeln(output,'@@@@@@@@@@@ in addmotherlinks @@@@@@@@@@@');
writeln(output,'------------ @@@@@ THREAD THIS gap:');
showafeature(output,agap);
writeln(output,'------------ @@@@@ INTO THIS feature:');
showafeature(output,thefeature);
}
   if thefeature^.mothers = nil then begin
if false then begin (* for debugging *)
      writeln(output,'************ ALL FEATURES: *************');
      writeln(output,'**** (also listed in the list file) ****');
      showfeatures(output,featurelist, false);
      writeln(output,'****************************************');
      writeln(output,'**** addmotherlinks: no mothers found for the feature:');
      showafeature(output, thefeature);
{ this is lister-specific code:
      rewrite(list);
      showfeatures(list,featurelist, true);
}
end;
{ halt; kills too soon }
{ttt}
      (* Probably this is wrong to do for gaps because we don't have
         the threading from total yet!! *)
      if not (    thefeature^.definition^.isgap
               or thefeature^.definition^.istotal)
      then halt;
   end
   else begin
{ddd}
      mom := thefeature^.mothers;
      previousMom := mom;
      done := false;
      while not done do begin
         if mom^.afeature = thefeature then begin
            done := true;
         end
         else begin
            if mom^.afeature^.definition^.istotal then begin
               (* We got to the end of the linked list,
                  so thread thefeature in front of the total *)
{writeln(output,'------------ addmotherlinks: THREADING IN');}
               new(gapthing);
               if mom = previousMom then begin
                  gapthing^.next := thefeature^.mothers;
                  thefeature^.mothers := gapthing;
               end
               else begin
                  previousMom^.next := gapthing; 
                  gapthing^.next := mom; 
               end;
               gapthing^.afeature := agap;  (* thread it in! *)
               done := true;
               if mom^.next <> nil then begin
                  writeln(output,'addmotherlinks: total points to something!');
                  halt;
               end;
            end
            else begin
               previousMom := mom;
               mom := mom^.next;
               if mom = nil then begin
                  writeln(output,'addmotherlinks: failed to find total');
                  halt;
               end
            end
         end;
      end;
{
writeln(output,'------------ @@@@@ adding more, result:');
showafeature(output,thefeature);
}
{
halt;
}
   end;
{
writeln(output,'------------ @@@@@ RESULT FOR THE feature:');
showafeature(output,thefeature);
}
end; (* addmotherlinks *)

begin (* threadgroup *)
   if ingroup then begin
      if groupfeature = nil then begin (* beginning of a group *)
{
writeln(output,'BEGIN OF GROUP ',groupnumber:1,' GGG');
writeafeature(output,f); writeln(output);
}
         (* this is the start of the group! *)
         groupfeature := f;
         (* this starts the group *)
      end
      else if f^.definition^.istotal then begin
         (* This total is the end of the group.
            At this point we have the entire group - since the total
            is supposed to be the end of the group.
            So the next thing to do is to thread the features
            into the total and the gap and total into the features. *)
         groupTotalFeature := f; (* use this for clarity *)
{
writeln(output);
writeafeature(output,f);writeln(output);
writeln(output);
writeln(output,'The total feature we are looking at: ========');
showafeature(output,f);
writeln(output,'The total feature''s definition: =============');
showadefinition(output,f^.definition);
}

{vvvv77}

{
writeln(output,'############## PRETHINGY');
countmarks(groupTotalFeature,-1);
writeln(output,'############## POSTTHINGY');
}
{
if groupTotalFeature^.others^.next^.next <> nil then begin
writeln(output,'***** PRE-BEFORE groupTotalFeature^.others^.next^.next <> nil');
showadefinition(output,groupTotalFeature^.definition);
showafeature(output,groupTotalFeature);
halt;
end;
}

         (* prepare to thread features into total. 
            gaps are done later based on the total. *)
         groupTotalCarrier := nil;

         (* Split out the names from the total 'nametag'. *)
{
writeln(output,'split out the total names from f^.nametag');
write(output,'"'); writestring(output,groupTotalFeature^.nametag);
writeln(output,'"');
}
         splitstring(groupTotalFeature^.nametag, '-', chr(9), nameparts);
                                                       (* 9 = tab *)

{
write(output,'***** fff ');
writeafeature(output,groupTotalFeature);
writeln(output);
}
         (* thread the features into the total *)
         anamepart := nameparts; (* anamepart steps through the nameparts *)
         for m := 1 to groupTotalFeature^.definition^.marks do begin
{
write(output,'***** fff mark ',m:1,' is ',location:1,' "');
writestring(output,anamepart^);
writeln(output,'"');
}
{
showafeature(output,groupTotalFeature);
}

            (* Find the feature(s) and the gap(s) for this mark *)
            gg := groupfeature; (* start at the first feature *)
{write(output,'===>TTT loop');}
            while gg <> nil do begin
{TTT}
{write(output,'===>'); writeafeature(output,gg); writeln(output);}

(*
if (gg^.number = 8)
or (gg^.number = 2) then begin
{it's failing to thread #8 for some reason - why? SOLVED}
writeln(output, 'TTT BUG POINT *******8888888888888888888888888888888 BEGIN #',
gg^.number:1);
write(output,'anamepart^:"');
writestring(output, anamepart^);writeln(output,'"');
write(output,'gg^.nametag:"');
writestring(output, gg^.nametag);writeln(output,'"');
if equalstring(anamepart^,gg^.nametag)
then writeln(output,    'equalstring(anamepart^,gg^.nametag)')
else writeln(output,'NOT equalstring(anamepart^,gg^.nametag)');
writeln(output, 'TTT BUG POINT *******8888888888888888888888888888888 END');
end;
*)

{
write(output,'   >'); writeadefinition(output,gg^.definition);
}
               if equalstring(anamepart^,gg^.nametag) then begin
                  if    gg^.definition^.isgap
                     or gg^.definition^.istotal then begin
                     (* If this happens something is VERY wrong! *)
                     writeln(output,'*** PROGRAM SHOULD NEVER BE HERE!');
                     writeln(output,'*** Total found matching gap or total');
                     halt;
                  end

                  else begin
{
writeln(output,'*** THREAD feature #',gg^.number:1,' INTO TOTAL TTT');
}
                     (* thread feature into total *)
                     if groupTotalCarrier = nil then begin
{
writeln(output,'*** if groupTotalCarrier = nil then begin');
}
                        new(groupTotalFeature^.others);
                        groupTotalCarrier := groupTotalFeature^.others;
                        groupTotalCarrier^.next := nil;
                     end
                     else begin
{
writeln(output,'*** if groupTotalCarrier <> nil then begin');
}
                        new(groupTotalCarrier^.next);
                        groupTotalCarrier := groupTotalCarrier^.next;
                        groupTotalCarrier^.next := nil;
                     end;
                     groupTotalCarrier^.afeature := gg;

                     (* thread total into feature! *)
                     if gg^.mothers = nil then begin
                        new(gg^.mothers);
                        gg^.mothers^.next := nil; (* NEW 2016aug30 *)
                        gg^.mothers^.afeature := groupTotalFeature;
{writeln(output,'*** threaded total into feature!');fff}
{IIIIIII}
                     end;
(*writeln(output,'ABOUT TO countmarks at mark number ',m:1);{TTT}*)
{fff}                countmarks(groupTotalFeature,m);
                  end;
               end;
               gg := gg^.next;
            end;

            anamepart := anamepart^.next;
         end; (* for threading marks into total loop *)
         if anamepart <> nil then begin
            writeln(output,'total names not all used');
            showafeature(output,f);
            showadefinition(output,f^.definition);
            halt;
         end;
{fff}    countmarks(groupTotalFeature,-1); (* final check *)

{iii}
{
writeln(output,'========= groupTotalFeature:');
showafeature(output,groupTotalFeature);
writeln(output,'============================');
}

         (* Now use the threaded total feature to thread the gaps!
            Thread all of the gaps in this group.
            Stop when we reach the total *)
         gg := groupfeature;
         while (not gg^.definition^.istotal) and (gg <> nil) do begin
            if gg^.definition^.isgap then begin
{
writeln(output);
writeln(output,'=== thread this gap: '); writeafeature(output,gg); writeln(output);
showafeature(output,gg);
}
{HIYA}
if superdebug then begin
writeln(output,'BUBBA gg^.number=', gg^.featurenumber:1,' ++++++++++++++++++++');
writeln(output,'BUBBA gg is: '); writeafeature(output,gg); writeln(output);
end;
               (* get the names and gap distance from the gap *)
               splitstring(gg^.nametag, '-', chr(9), nameparts); (* 9 = tab *)
               (* Example for a gap with nametag: "p35-(22)-p10 4164377 Gap"
                  nameparts^: "p35"
                  nameparts^.next^: "(22)"
                  nameparts^.next^.next^: "p10"
                *)

{
write(output,'* nameparts^: "');
writestring(output,nameparts^);
writeln(output,'"');
write(output,'* nameparts^.next^: "');
writestring(output,nameparts^.next^);
writeln(output,'"');
write(output,'* nameparts^.next^.next^: "');
writestring(output,nameparts^.next^.next^);
writeln(output,'"');
}

               leftstring  := nameparts^;
               gapstring   := nameparts^.next^;
                  (* gapstring is only needed for checking! *)
               rightstring := nameparts^.next^.next^;

               (* read the gap number: convert gapstring to a number *)
               gap := 0; (* start the number up *)
               if     (gapstring.letters[1] <> '(')
                  and (gapstring.letters[gapstring.length] <> ')')
               then begin
                  writeln(output,'Gap string found without surrounding "()"');
                  showafeature(output,gg);
                  halt;
               end
               else begin
                  gapstring.current := 2;
                  while gapstring.current <= gapstring.length - 1 do begin
                     aletter := gapstring.letters[gapstring.current];
                     if not (aletter in
                             ['0','1','2','3','4','5','6','7','8','9'])
                     then begin
                        writeln(output,'Gap contains non-digit: "',
                                        aletter,'"');
                        showafeature(output,gg);
                        halt;
                     end;
                           gap := (10*gap) + (ord(aletter) - ord('0'));
                     gapstring.current := succ(gapstring.current);
                  end;
               end;
               {if not((gap = abs(gg^.fromrange)) or (gap = abs(gg^.torange)))}
if superdebug then begin
writeln(output,'BUBBA gap is ',gap:1);
writestring(output, leftstring);writeln(output,'<-  leftstring BUBBA');
writestring(output,rightstring);writeln(output,'<- rightstring BUBBA');
end;
               if gap <> gg^.torange - gg^.fromrange
               then begin
                  writeln(output,'Gap in nametag does not match range:');
                  showafeature(output,gg);
                  halt;
               end;
               aGapFeature := gg; (* give the gap a good name *)

               (* Search the group features for ones that match this gap *)
               (* Use the names and gap distance to find the features *)
               leftgap := nil;
               rightgap := nil;
               ff := groupfeature;
               while     (ff <> groupTotalFeature)
                     and ((leftgap=nil) or (rightgap=nil))
               do begin
                  if not (ff^.definition^.isgap or ff^.definition^.istotal)
                  then begin
                     if round(ff^.relcoo) = aGapFeature^.fromrange then begin
{writeln(output,'fromrange coomatch');}
                        if equalstring(leftstring,ff^.nametag) then begin
{writeln(output,'equalstring(leftstring,ff^.nametag)');}
                           leftgap := ff;
                        end;
                     end;
                     if round(ff^.relcoo) = aGapFeature^.torange then begin
{writeln(output,'torange coomatch');}
                        if equalstring(rightstring,ff^.nametag) then begin
{writeln(output,'equalstring(rightstring,ff^.nametag)');}
{showafeature(output,ff);}
                           rightgap := ff;
                        end;
                     end;
                  end;
{writeln(output,'BUBBBA BEFORE ff := ff^.next; ');}
                  ff := ff^.next;
{writeln(output,'BUBBBA AFTER  ff := ff^.next; ');}
               end;

if superdebug then begin
write(output,'BUBBA leftgap: '); writeafeature(output,leftgap); writeln(output);
write(output,'BUBBA rightgap: '); writeafeature(output,rightgap); writeln(output);
end;

               (* Tests of the linked list so far: *)
               if ((leftgap=nil) or (rightgap=nil)) then begin
                  writeln(output,'gap ends not found:');
                  showafeature(output,aGapFeature);
                  halt;
               end;
               if leftgap^.mothers = nil then begin
                  writeln(output,'ERROR: missing total for leftgap');
                  halt;
               end;
               if rightgap^.mothers = nil then begin
                  writeln(output,'ERROR: missing total for rightgap');
                  halt;
               end;

               (* At this point we know the features that match the gap
                  at ff, they are leftgap and rightgap. *)

               (* Next, we thread the two gap features into the gap.
                  There are ONLY two. *)
               (* do the left side of the gap: *)
               if aGapFeature^.others <> nil then begin
                  writeln(output,'ERROR: aGapFeature not nil!');
                  halt;
               end;
               new(aGapFeature^.others);
               groupGapCarrier := aGapFeature^.others;
               groupGapCarrier^.next := nil;
               groupGapCarrier^.afeature := leftgap;
               (* do the right side of the gap: *)
               new(groupGapCarrier^.next);
               groupGapCarrier := groupGapCarrier^.next;
               groupGapCarrier^.next := nil;
               groupGapCarrier^.afeature := rightgap;

               (* Now thread the gap as a mother of each feature.
                  There can be multiple mothers for a feature. *)
{iii}
               addmotherlinks(aGapFeature, rightgap);
               addmotherlinks(aGapFeature,  leftgap);
if superdebug then begin
writeln(output,'BUBBA final aGapFeature is: ========');
showafeature(output,aGapFeature);
writeafeature(output,aGapFeature);writeln(output);
{
writeln(output,'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm done');
writeln(output,'**********======= rightgap:');
showafeature(output,rightgap);
writeln(output,'**********======= leftgap:');
showafeature(output,leftgap);
}
end;

            end;
            gg := gg^.next

(* initial spot for if gg^.duplicateprevious <> nil then begin
addmotherlinks(aGapFeature, gg^.duplicateprevious);
end; - has pretty good effect. *)

         end; (* end of thread all of the gaps in this group *)

if superdebug then begin
writeln(output,'BUBBA: show AFTER threading:');
gg := groupfeature;
while gg <> nil do begin
writeafeature(output,gg);writeln(output);
gg := gg^.next
end;
end;

         (* Add mother links to the feature that has the vertical bar *)
{ddd}
{
writeln(output,'dddddddddddddddddddddddddddddddddddddd');
}
         gg := groupfeature; (* start at the first feature *)
         while gg <> nil do begin
{
writeln(output,'BUBBA before vertical thing gg is: ==='); writeafeature(output,gg);
}
{
            if gg^.duplicateprevious <> nil then begin
}
            (* 2016oct30 AVOID MODIFYING GAPS!!! *)
            if      (gg^.duplicateprevious <> nil)
                and (not gg^.definition^.isgap)
            then begin
               (* thread the gap into the feature: *)
               addmotherlinks(aGapFeature, gg^.duplicateprevious);
{
writeln(output,'gg^.duplicateprevious AFTER:');
showafeature(output,gg^.duplicateprevious);
writeln(output,'aGapFeature AFTER===================:');
showafeature(output,aGapFeature);
}
               (* now alter aGapFeature so that it points to the
                  non-duplicate feature! *)
{
writeln(output,'what aGapFeature points to:');
writeafeature(output,aGapFeature^.others^.afeature);writeln(output);
}
               (* 2016oct30: KEY CHANGE to fix hindi problem! *)
               if (not aGapFeature^.definition^.isgap)
               then aGapFeature^.others^.afeature := gg^.duplicateprevious;
{
writeln(output,'aGapFeature AFTER FIXED? ===================:');
writeln(output,'what aGapFeature points to AFTER FIX::');
writeafeature(output,aGapFeature^.others^.afeature);writeln(output);
writeln(output,'aGapFeature FINAL RESULT ===================:');
writeln(output,'what aGapFeature points to AFTER FIX::');
showafeature(output,aGapFeature);
}
            end;
{
writeln(output,'BUBBA after vertical thing gg is: ===='); writeafeature(output,gg);
}
            gg := gg^.next;
         end;

if superdebug then begin
writeln(output,'BUBBA: show AFTER motherlinks:========');
gg := groupfeature;
while gg <> nil do begin
writeafeature(output,gg);writeln(output);
gg := gg^.next
end;
end;

         groupTotalFeature := nil; (* reset *)
         ingroup := false;
{fff}
         groupfeature := nil; (* clear the group feature now that the
                                 total parts are threaded! *)
      end; (* total threading *)

{writeln(output,'END OF GROUP ',groupnumber:1,' GGG');}
   end; (* ingroup test *)
end; (* end threadgroup *)

begin (* readdefinitionsandfeatures *)
   reset(afile);
   emptyafile := eof(afile); (* defines if file contains anything *)
{zzzccc}
   comments := nil;
   definitionlist := nil;
   new(featurelist);
   clearfeature(featurelist);
   countdefinitions := 0;
   uniquedefinitions := 0;
   countfeatures := 0;
   uniquefeatures := 0;
   countribls := 0;
   countboundaries := 0;
   d := definitionlist;
   f := featurelist;
   countpetals := 0;
   groupnumber := 0;
   firstfeatureofgroup := false;

{gggg}
   groupfeature := nil;
   groupnumberinfile := 0;
   ingroup := false;
   new(nameparts);
   clearstring(nameparts^); (* start out clean *)
   firstfeature := true;
   while not eof(afile) do begin
      if eoln(afile) (* skip blank line *)
      then readln(afile)
      else begin
         skipblanks(afile);

         (* determine the identifier but don't read it: *)
         identifier := afile^;
{writeln(output,'identifier="',identifier,'"');}

         if identifier = '*'
         then begin (* read comment *)
            if (comments = nil) then begin
               new(comments);
               clearstring(comments^); (* start out clean *)
               currentcomment := comments;
            end
            else begin
               new(currentcomment^.next);
               currentcomment := currentcomment^.next;
            end;
            readstringline(afile,currentcomment^);
{writestringlines(output,currentcomment);}
{zzzccc}
         end

         else if identifier = 'd'
         then begin (* read definition *)
            if definitionlist = nil
            then begin
               new(definitionlist);
               cleardefinition(definitionlist);
               d := definitionlist;
               dprevious := d;
            end
            else begin
               dprevious := d;
               new(d^.next);
               d := d^.next;
               cleardefinition(d);
            end;
            readadefinition(afile, d);
{
write(output, 'read: '); writeadefinition(output,d); writeln(output);
}
            readln(afile); (* this allows comments at the end of the def *)
            countdefinitions := succ(countdefinitions);
            uniquedefinitions := succ(uniquedefinitions);
            d^.definitionnumber := uniquedefinitions;

            (* see if we can locate the definition, based on the nametag *)
            dtest := definitionlist;
            done := false;
            while not done do begin
               if dtest = nil
               then done := true
               else begin
{ add this 2008 Aug 06:}
                  if equaldefinition(dtest, d)
{ remove this 2008 Jul 22:
                  if equalstring(dtest^.nametag, d^.nametag)
}

{
                     and EqualDefLocations(dtest, d)
}
{rrr}
                     and (dtest^.definitionnumber <> d^.definitionnumber)
                  then begin
                     done := true;
                     (* We can't remove the duplicate because features
                        can already point to it!  So just warn them. *)
                     barout;
                     writeln(output, '*** WARNING: A duplicate definition',
                                     ' was found at definition ',
                                   countdefinitions:1,':');
                     write(output, '*** ');
                     writequotestring(output,d^.nametag);
                     writeln(output,'.');
                     writeln(output, '*** ',
                                     'The first definition (number ',
                                     dtest^.definitionnumber:1,
                                     ') will be used.');
{rrr}
{
                     if not EqualDefLocations(dtest, d) then begin
                        writeln(output, 'BUT WAIT!');
                        writeln(output, 'THE LOCATIONS ARE NOT EQUAL!');
                        writeln(output, 'THIS IS FATAL!');
writeln(output,'===');
                        showadefinition(output,dtest);
writeln(output,'===');
                        showadefinition(output,d);
writeln(output,'===');
                        writeadefinition(output,dtest);
writeln(output,'===');
                        writeadefinition(output,d);
writeln(output,'===');
                        barout;

  2006 Oct 14.  Can't be fatal: bars can have different sizes.
                        halt
                     end;
}
                     barout;

{
writeln(output,'definitionlist is:-------- BEFORE 0');
showdefinitions(output,definitionlist);
writeln(output,'-------------------------- BEFORE 1');

if dprevious^.next = d
then begin
writeln(output,'dprevious^.next = d as expected!');
end;

if d^.next = nil
then begin
writeln(output,'d^.next = nil as expected!');
end;
}

                     (* The following solved the duplicate definition bug *)
                     (* remove the item we just read from the list *)
                     dprevious^.next := nil;
                     dispose(d);
                     done := true; (* there is no more to do since there
                                      cannot be other duplicates *)
                     (* move d to the end of the list: *)
                     d := dprevious;
{
this is unnecessary, but worked:
                     d := definitionlist;
                     while d^.next <> nil do d := d^.next;
}

{
writeln(output,'definitionlist is:-------- AFTER 0');
showdefinitions(output,definitionlist);
writeln(output,'-------------------------- AFTER 1');
}

{
writeln(output, 'the dprevious defintion is:');
writeadefinition(output, dprevious); writeln(output);
}

                     uniquedefinitions := pred(uniquedefinitions);
                  end;
                  if not done then begin (* step forward *)
                     dtest := dtest^.next;
                  end;
               end;
            end;
(*
if ingroup then begin
   writeadefinition(output,d); {writeln(output); done by the writeadefinition}
end;
*)
         end

         else if identifier = 'r'
         then begin (* read ribl matrix *)
            (* read in the matrix *)
            getriblmatrix(afile, matrix);

            locatedefinition(matrix^.riblname,definitionlist,thedefinition);
            if thedefinition = nil then begin
               write(output,'A definition for Ribl matrix ');
               writequotestring(output,matrix^.riblname);
               writeln(output,' was not found in the features.');
               halt
            end;

            (* make sure that the definition is in the
               range of the weight matrix. *)
            if (thedefinition^.min < matrix^.frombase) or
               (thedefinition^.max > matrix^.tobase) then begin
               writeln(output, 'Definition:');
               writeadefinition(output,thedefinition);
               writeln(output);
               writeln(output, 'Violates The From-To Bounds',
                       ' of its Matrix:');
               writeln(output,'matrix frombase: ',matrix^.frombase:1);
               writeln(output,'matrix   tobase: ',matrix^.  tobase:1);
               halt
            end;

            (* slip the matrix into the data structure *)
            thedefinition^.matrix := matrix;
            countribls := succ(countribls);
         end

         else if identifier = 'b'
         then begin (* define boundaries *)
            (* read the boundary name *)
            skipnonblanks(afile);
            skipblanks(afile);
            readquotestring(afile, aname);
            locatedefinition(aname,definitionlist,thedefinition);
            if thedefinition = nil then begin
               write   (output,'WARNING: A definition for the boundaries: ');
               writequotestring(output,aname);
               writeln(output,'          was not found in the features.');
            end
            else with thedefinition^ do begin
               readln(afile, RiboundFeature, ZboundFeature, PboundFeature);
               countboundaries := succ(countboundaries);
            end;
         end

         else if identifier = 'p'
         then begin (* define color rectangle, a petal *)
         (* petal "ribl-name" el c eh es eb fh fs fb th *)

            (* read the color rectangle name *)
            skipnonblanks(afile);
            skipblanks(afile);
            readquotestring(afile, aname);
            locatedefinition(aname,definitionlist,thedefinition);
            if thedefinition = nil then begin
               write  (output,'WARNING: A definition',
                                      ' for the color rectangle: ');
               writequotestring(output,aname);
               writeln(output);
               writeln(output,'         was not found in the features.');
               readln(afile);
            end
            else with thedefinition^.petal do begin
               read(afile, el);
{
writeln(output,'the value of el is ',el:1);
}
               skipblanks(afile);
               read(afile, c);
               if not ((c='r') or (c='h')) then begin
                  yell;
                  writeln(output,' feature');
                  writequotestring(output,aname);
                  writeln(output,': color type must be r or h, not "', c,'"');
                  halt;
               end;
               readln(afile, eh, es, eb, fh, fs, fb, spare);

{
               if
                  (eh < 0) or (eh > 1) or
                  (es < 0) or (es > 1) or
                  (eb < 0) or (eb > 1) or
                  (fh < 0) or (fh > 1) or
                  (fs < 0) or (fs > 1) or
                  (fb < 0) or (fb > 1)
               then begin
                  yell;
                  writeln(output,' feature');
                  writequotestring(output,aname);
                  writeln(output,': eh, es, eb, fh, fs, and fb ');
                  writeln(output,'must have values between 0 and 1');
                  halt;
               end;
}

               if
                  (eh > 1) or
                  (es > 1) or
                  (eb > 1) or
                  (fh > 1) or
                  (fs > 1) or
                  (fb > 1)
               then begin
                  yell;
                  writeln(output,' feature');
                  writequotestring(output,aname);
                  writeln(output,': eh, es, eb, fh, fs, and fb ');
                  writeln(output,'must have values less than 1');
                  halt;
               end;

{
This is a spare variable for now so it has no restrictions
               if
                  (th < 0) or (th > 1)
               then begin
                  yell;
                  writeln(output,' feature');
                  writequotestring(output,aname);
                  writeln(output,': spare');
                  writeln(output,'must have values between 0 and 1');
                  halt;
               end;
}

               countpetals := succ(countpetals);
            end;
         end

         else if identifier = '@'
         then begin (* read feature *)
            countfeatures := succ(countfeatures);
{
            f^.featurenumber := countfeatures;
            f^.featuregroup := groupnumber;
            f^.featureisfirstingroup := firstfeature; (* mark into the feature *)
}

            if firstfeature then begin (* first feature of entire list *)
               (* the feature must be unique, just read it in *)
               readafeature(afile, definitionlist, f);
               readln(afile); (* this allows comments
                                 at the end of the feature *)
               f^.featurenumber := countfeatures;
               f^.featuregroup := groupnumber;
               f^.featureisfirstingroup := true;
               uniquefeatures := succ(uniquefeatures);
               firstfeature := false; (* set to false for later features *)
            end
            else begin
               (* determine if the feature is unique *)
               new(newfeature);
               clearfeature(newfeature);
               readafeature(afile, definitionlist, newfeature);
               readln(afile); (* this allows comments
                                 at the end of the feature *)
               if not featureinlist(featurelist, newfeature, oldfeature)
               then begin
                  (* since the feature is not in the list, add it in *)
                  f^.next := newfeature;
                  f := f^.next;
                  f^.featurenumber := countfeatures;
                  f^.featuregroup := groupnumber;
                  f^.featureisfirstingroup := firstfeatureofgroup;
{zzzfff}
                  uniquefeatures := succ(uniquefeatures);
               end
               else begin
                  writeln(output,'This feature was found more than once:');
                  writeafeature(output,newfeature);
                  writeln(output);

{2007 Mar 26 ppp}

                  (* Keep all duplicates in the list! *)
                  f^.next := newfeature;
                  f := f^.next;
                  f^.featurenumber := countfeatures;
                  f^.featuregroup := groupnumber;
{zzzfff}
                  f^.featureisfirstingroup := firstfeatureofgroup;

                  if KeepDuplicates
{ppp do something about orfs here }
                  then begin
                     writeln(output,'It is being kept.');
                     f^.duplicateprevious := nil;
                  end
                  else begin
                     writeln(output,'It will be ignored.');
                     f^.duplicateprevious := oldfeature;
                  end

               end
            end;
{zzzfff}
            if firstfeatureofgroup then firstfeatureofgroup := false;

            threadgroup;
{ttt Is this the right place to examine the list or should it be later?}
{
rewrite(list);
writeln(list,'after threadgroup showfeatures(list,featurelist, true);');
showfeatures(list,featurelist, true);
}
         end

         else if identifier = 'g'
         then begin (* start of group feature *)
            ingroup := true;
            groupnumber := groupnumber + 1;
{writeln(output, '--- groupnumber is now ',groupnumber:1);}
            mycharacter := '?';
{
writeln(output,'mycharacter is "',mycharacter,'"');
writeln(output,'ord(mycharacter) is "',ord(mycharacter):1,'"');
}
            while (mycharacter <> ' ') and (not eoln(afile)) do begin
               (* read past the word 'group' *)
               read(afile,mycharacter);
{writeln(output, '--- mycharacter "',mycharacter,'"');}
               if eoln(afile) then begin
                  writeln(output,'found end of line while reading "group"');
                  halt;
               end;
            end;
            readln(afile, groupnumberinfile);
{writeln(output, 'groupnumberinfile=', groupnumberinfile:1);}
{zzqq}
            if groupnumberinfile <> groupnumber then begin
               writeln(output, 'WARNING: counted groupnumber=',groupnumber:1,
                             ' does not match groupnumberinfile=',
                             groupnumberinfile:1);
{showfeatures(output,featurelist, true);}
            end;
            firstfeatureofgroup := true;
         end

         else begin
            writeln(output,'features file lines must be blank or',
                           ' begin with one of "*d@g', (* g=group *)
                           'rbp',
                           '", not "',identifier,'".');
            halt
         end
      end
   end;

{
showfeatures(output,featurelist, true);
writeln(output,'PASSPOINT');
halt;
}
{zzzqqqeee}

   (* 2008 Mar 11. There can be a non-empty features file
      which only contains definitions and no features.
      Call this an empty features file. *)
   if featurelist <> nil then begin
      if featurelist^.id.length = 0 then begin
         emptyafile := true;
      end
   end;

   if not emptyafile then begin
      (* check that any definition which claims to have a walker
         actually has a defined weight matrix *)
      if definitionlist <> nil then begin
         d := definitionlist;
         missingmatrix := false;
         while d <> nil do begin
{
write(output, 'testing:');
writeadefinition(output,d);
writeln(output);
}
            with d^ do if background.length = 2
            then if background.letters[2] in ['w','W','l','L','i','I']
            then if d^.matrix = nil then begin
               missingmatrix := true;
               writeln(output, 'Definition:');
               writeadefinition(output,d);
               writeln(output);
               writeln(output,'is missing a Ribl weight matrix');
            end;
            d := d^.next;
         end;
         if missingmatrix then begin
            writeln(output,'readdefinitionsandfeatures:',
                           ' missingmatrix is true');
            halt
         end;
      end;
   end; (* file check *)

   writeln(output,'**************************************************');
   if emptyafile then begin
      writeln(output,'** Empty Features File ***************************');
      writeln(output,'** The features file may have characters in it, **');
      writeln(output,'** but it contains no features.                 **');
      writeln(output,'**************************************************');
      (* make sure we don't give any empty features *)
      dispose(featurelist);
      featurelist := nil;
   end
   else begin
      write(output,countdefinitions:1,' definition');
      plural(output,countdefinitions);
      writeln(output,' read in');

      write(output,uniquedefinitions:1,' unique definition');
      plural(output,uniquedefinitions);
      writeln(output,' found');

      write(output,countribls:1,' definition');
      if countribls = 1
      then writeln(output,' has an Ribl matrix')
      else writeln(output,'s have Ribl matricies');

      write(output,countboundaries:1,' definition');
      if countboundaries = 1
      then writeln(output,' boundry defined')
      else writeln(output,' boundries defined');

      write(output,countpetals:1);
      if countpetals = 1
      then writeln(output,' petal (color rectangle behind a walker) defined')
      else writeln(output,' petals (color rectangles behind walkers) defined');

      write(output,countfeatures:1,' feature');
      plural(output,countfeatures);
      writeln(output,' read in');

      write(output,uniquefeatures:1,' unique feature');
      plural(output,uniquefeatures);
      writeln(output,' found');

{
(* show just the first feature *)
writeln(output,'~~~~~~~~~~~~~~~ p10 ~~~~~~~~~~~~~~~');
showafeature(output,featurelist);
writeln(output,'the feature should have 3 mothers but it is missing the p35!');
2016sep03fixed!
writeln(output,'this feature now has the correct 4 mothers!');
}
{halt;}
{iii debug}

if false then begin (* final display for debugging *)
writeln(output);
writeln(output,'******* @ end of readdefinitionsandfeatures: *******');
writeln(output,'******* DEFINITIONS:');
if false then showdefinitions(output,definitionlist);
writeln(output);
writeln(output,'******* FEATURES:');
if true then showfeatures(output,featurelist,true);
writeln(output);
writeln(output,'******* @ end of readdefinitionsandfeatures: *******'); {sss}
{
halt;
}
end;
{
writeln(output, 'end readdefinitionsandfeatures halt'); halt;
}

   end;
   writeln(output,'**************************************************');
end;
(* end module readdefinitionsandfeatures version = 13.33; (@ of lister.p 2017 Feb 14 *)

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

(* begin module makelogo.protectcharacter *)
procedure protectcharacter(c: char;
                       var protectioncharacter: char;
                       var needed: boolean);
(* In PostScript, special characters must be protected against.
This routine looks at a character c and returns a protection character
if it is needed.
The parenthesis is used in PostScript to indicate the bounds of a
string, while the percent is the comment character.  The backslash also needs
protection, since it is the escape to indicate that the next character is part
of the string. *)
begin
   if c in ['(',')','%','\']
   then begin
      protectioncharacter := '\';
      needed := true
   end
   else begin
      protectioncharacter := ' ';
      needed := false
   end
end;
(* end module makelogo.protectcharacter version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module makelogo.protectpostscript *)
procedure protectpostscript(var afile: text; c: char);
(* Special characters must be protected against!  Put out a protective
backslash for character c which would otherwise destroy the PostScript
interpreter.  The parenthesis is used in PostScript to indicate the bounds of a
string, while the percent is the comment character.  The backslash also needs
protection, since it is the escape to indicate that the next character is part
of the string. *)
var
   needed: boolean; (* is protection needed? *)
   protectionchar: char; (* is protection needed? *)
begin
   protectcharacter(c, protectionchar, needed);
   if needed then write(afile,protectionchar);
end;
(* end module makelogo.protectpostscript version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module makelogo.mark.package *)
(******************************************************************************)
(* When transferred to another program, this package
of procedures will do all the mark routines *)

(* begin module makelogo.getmark *)
(* end module makelogo.getmark *)

(* begin module makelogo.marktype *)
(* end module makelogo.marktype *)

(* begin module makelogo.circlesymbol *)
(* end module makelogo.circlesymbol *)

(* begin module makelogo.trianglesymbol *)
(* end module makelogo.trianglesymbol *)

(* begin module makelogo.squaresymbol *)
(* end module makelogo.squaresymbol *)

(* begin module makelogo.linesymbol *)
(* end module makelogo.linesymbol *)
 
(* begin module makelogo.boxsymbol *)
(* end module makelogo.boxsymbol *)
 
(* begin module makelogo.usersymbol *)
(* end module makelogo.usersymbol *)
 
(* begin module makelogo.markup *)
(* end module makelogo.markup *)
 
(* begin module makelogo.marksymbols *)
(* end module makelogo.marksymbols *)
 
(******************************************************************************)
(* end module makelogo.mark.package *)

(* begin module makelogo.getmark *)
procedure getmark(var marks, logo: text;
                  var marksymbol: char;
                  var marktype: char;
                  var markbase1, markbits1,
                      markbase2, markbits2,
                      markscale: real;
                  var nextmark: integer;
                  var waitfornextpiece: boolean;
                  var marksorder: char);
(* Obtain the information for placing the next mark (markbase1,markbits1),
its kind (marksymbol) and the integer location (nextmark).  The logo
file is used for user defined symbols.
If waitfornextpiece is true then don't do anything *)
var
   done: boolean; (* done searching for data *)

begin
   done := false;
   if not waitfornextpiece then repeat
      if eof(marks) then begin
         nextmark := maxint;
         marksymbol := ' ';
         done := true;
      end
      else begin
         if eoln(marks) or (marks^=' ') then begin
            readln(marks); (* skip comments.  Allowing a blank character should
               avoid a lot of frustration for people, because otherwise the
               program will halt (see just below) and it is hard to find the
               blank character! *)
            marksymbol := '!'; (* fill with identifiable mark *)
         end
         else begin
            read(marks, marksymbol);
            if not (marksymbol in ['c','b','l','s','t','*','u','U','p','o'])
            then begin
               writeln(output,'mark symbol in file marks',
                              ' must be one of: "cblst*uUpo"');
               writeln(output,'"',marksymbol,'" is not allowed');
               halt
            end;

            if (marksymbol <> '*') and
               (marksymbol <> 'u') and
               (marksymbol <> 'U') and
               (marksymbol <> 'p') and
               (marksymbol <> 'o') then begin
               read(marks, marktype);
               if not (marktype in ['s','f','d'])
               then begin
                  writeln(output,'mark type in file marks',
                                 ' must be one of: "sfd"');
                  writeln(output,'"',marktype,'" is not allowed');
                  writeln(output,'ascii character: ',ord(marktype):1);
                  halt
               end;
            end;

            case marksymbol of
               '*': readln(marks); (* skip comments *)
               'c','t','s': begin
                  readln(marks, markbase1, markbits1, markscale);
                  markbase2 := 0;
                  markbits2 := 0;
                  if markscale <= 0.0 then begin
                     writeln(output,'mark scale must be positive');
                     halt
                  end;
                  nextmark := trunc(markbase1);
                  done := true;
               end;
               'l','b': begin
                  readln(marks, markbase1, markbits1, markbase2, markbits2);
                  nextmark := trunc(markbase1);
                  done := true;
               end;
               'u': begin (* define the user procedure *)

                  while not done do begin
                     if eof(marks) then begin
                        writeln(output,'The "!" to mark the end',
                                       ' of a user defined symbol',
                                       ' in the marks file is missing.');
                        halt
                     end
                     else if marks^<>'!'
                          then copyaline(marks,logo)
                          else done := true;
                  end;
                  readln(marks); (* skip the ! line *)
                  done := false;
               end;
               'U': begin (* grab the coordinates for the user, but DO NOT
                             move to the next line.  Later, in markup, the
                             coordinates in drawing space get calculated and
                             THEN the rest of the line gets copied out *)
                  read(marks, markbase1, markbits1, markbase2, markbits2);
                  nextmark := trunc(markbase1);
                  done := true;
               end;
               'p': begin (* start waiting for next piece *)
                  waitfornextpiece := true;
                  readln(marks);
               end;
               'o': begin (* change overwrite state *)
                  if eoln(marks) then begin
                     writeln(output,'The "o" command must be followed',
                                    ' by a character, bNADF');
                     halt
                  end;
                  readln(marks,marksorder);
               end;
            end;
         end;
      end;
   until done or waitfornextpiece;
end;
(* end module makelogo.getmark version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.marktype *)
procedure makemarktype(var f: text; marktype: char);
(* make the mark type to the file f *)
begin
   case marktype of
      (* for filling, we stroke first!  This ensures that
         the symbol edges are identical whether stroked or not! *)
      'f': writeln(f,' gsave stroke grestore fill');
      's': writeln(f,' stroke');
      'd': writeln(f,' [3] 0 setdash stroke');
   end;
end;
(* end module makelogo.marktype version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.circlesymbol *)
procedure circlesymbol(var f: text; x, y, radius: real; marktype: char);
(* write a circle to file f at (x, y), of given radius
and mark it according to marktype *)
begin
  writeln(f, ' ', x:pwid:pdec,' cm',
             ' ', y:pwid:pdec,' cm',
             ' ', radius:pwid:pdec,' cm',
             ' circlesymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.circlesymbol version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.trianglesymbol *)
procedure trianglesymbol(var f: text; x, y, radius: real; marktype: char);
(* write a triangle to file f at (x, y), of given "radius"
and mark it according to marktype *)
begin
  writeln(f, ' ', x:pwid:pdec,' cm',
             ' ', y:pwid:pdec,' cm',
             ' ', radius:pwid:pdec,' cm',
             ' trianglesymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.trianglesymbol version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.squaresymbol *)
procedure squaresymbol(var f: text; x, y, side: real; marktype: char);
(* write a square to file f at (x, y), of given "side"
and mark it according to marktype *)
begin
  writeln(f, ' ', x:pwid:pdec,' cm',
             ' ', y:pwid:pdec,' cm',
             ' ', side:pwid:pdec,' cm',
             ' squaresymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.squaresymbol version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.linesymbol *)
procedure linesymbol(var f: text; x1, y1, x2, y2: real; marktype: char);
(* write a line to file f at (x1, y1), (x2, y2)
and mark it according to marktype *)
begin
  writeln(f, ' ', x1:pwid:pdec,' cm',
             ' ', y1:pwid:pdec,' cm',
             ' ', x2:pwid:pdec,' cm',
             ' ', y2:pwid:pdec,' cm',
             ' linesymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.linesymbol version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.boxsymbol *)
procedure boxsymbol(var f: text; x1, y1, x2, y2: real; marktype: char);
(* write a box to file f at (x1, y1), (x2, y2)
and mark it according to marktype *)
begin
  writeln(f, ' ', x1:pwid:pdec,' cm',
             ' ', y1:pwid:pdec,' cm',
             ' ', x2:pwid:pdec,' cm',
             ' ', y2:pwid:pdec,' cm',
             ' boxsymbol');
  makemarktype(f,marktype);
end;
(* end module makelogo.boxsymbol version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.usersymbol *)
procedure usersymbol(var f: text; x1, y1, x2, y2: real;
                     var marks: text);
(* write a user symbol to file f at (x1, y1), (x2, y2) *)
begin
  writeln(f, ' ', x1:pwid:pdec,' cm',
             ' ', y1:pwid:pdec,' cm',
             ' ', x2:pwid:pdec,' cm',
             ' ', y2:pwid:pdec,' cm ');
  copyaline(marks, f);
end;
(* end module makelogo.usersymbol version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.markup *)
procedure markup(var logo: text;
                     thecharacterwidth: real;
                     cmperbit: real;
                     position: integer;
                 var marks: text;
                 var marksymbol: char;
                 var marktype: char;
                 var markbase1, markbits1,
                     markbase2, markbits2,
                     markscale: real;
                 var nextmark: integer;
                 var waitfornextpiece: boolean;
                 var marksorder: char);
(* markup the logo with the mark as defined by its symbol,
type, coordinate and scale factor. *)
var
   radius: real; (* radius of a circle mark, or the radius of a circle
                    a triangle is enscribed in or the side of a square. *)
   x1: real; (* an x coordinate on the logo *)
   y1: real; (*  a y coordinate on the logo *)
   x2: real; (* an x coordinate on the logo *)
   y2: real; (*  a y coordinate on the logo *)
(* mark the logo up with marks *)
begin
   while (position = nextmark) and
         (not waitfornextpiece)
   do begin
      (* do the mark *)
{
writeln(output,marksymbol,' ',markbase1:5:3, ' ',markbits1:5:3,
                          ' ',markbase2:5:3, ' ',markbits2:5:3,
                          ' ',markscale:5:3,' ',nextmark:5);
}
      writeln(logo,'gsave');

      case marksymbol of
         'c','t','s': begin
            x1 := (markbase1 - nextmark + 0.5) * thecharacterwidth;
            y1 := markbits1 * cmperbit;
            radius := markscale * thecharacterwidth / 2.0;
            case marksymbol of
               'c': circlesymbol(logo,x1,y1,radius,marktype);
               't': trianglesymbol(logo,x1,y1,radius,marktype);
               's': squaresymbol(logo,x1,y1,radius,marktype);
            end;
         end;

         'l','b','U': begin
            x1 := (markbase1 - nextmark + 0.5) * thecharacterwidth;
            y1 := markbits1 * cmperbit;
            x2 := (markbase2 - nextmark + 0.5) * thecharacterwidth;
            y2 := markbits2 * cmperbit;
            case marksymbol of
               'b':  boxsymbol(logo,x1,y1,x2,y2,marktype);
               'l': linesymbol(logo,x1,y1,x2,y2,marktype);
               'U': usersymbol(logo,x1,y1,x2,y2,marks);
            end;
         end;
      end;

      writeln(logo,'grestore');

      (* get the next one *)
      getmark(marks,logo,marksymbol,marktype,
              markbase1,markbits1,markbase2,markbits2,
              markscale,nextmark,waitfornextpiece, marksorder);
   end;
end;
(* end module makelogo.markup version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module makelogo.marksymbols *)
procedure marksymbols(var l: text);
(* define postscript symbols to file l *)
begin
writeln(l,'/circlesymbol { % x y radius circlesymbol - (path)');
writeln(l,'newpath 0 360 arc closepath} bind def');
writeln(l);

(*
writeln(l,'% axis of triangle for debugging');
writeln(l,'/firstaxis {');
writeln(l,'gsave');
writeln(l,'1 0 0 setrgbcolor');
writeln(l,'newpath 0 0 moveto 100 0 lineto (X) show stroke');
writeln(l,'0 0 moveto 0 50 lineto (Y) show stroke');
writeln(l,'grestore } def');
writeln(l,'/secondaxis {');
writeln(l,'gsave');
writeln(l,'0 1 0 setrgbcolor');
writeln(l,'newpath 0 0 moveto 100 0 lineto (XX) show stroke');
writeln(l,'0 0 moveto 0 50 lineto (YY) show stroke');
writeln(l,'grestore } def');
writeln(l,'/thirdaxis {');
writeln(l,'gsave');
writeln(l,'0 0 1 setrgbcolor');
writeln(l,'newpath 0 0 moveto 100 0 lineto (XXX) show stroke');
writeln(l,'0 0 moveto 0 50 lineto (YYY) show stroke');
writeln(l,'grestore } def');
writeln(l);
*)

writeln(l,'/sqrt3 3 sqrt def');
writeln(l,'/trianglesymbol { % x y radius trianglesymbol - (path)');
writeln(l,'/r exch def');
writeln(l,'/sqrt3r sqrt3 r mul def');
writeln(l,'translate');
(*writeln(l,'% firstaxis'); *)
writeln(l,'120 rotate');
(*writeln(l,'% secondaxis'); *)
writeln(l,'0 r translate');
writeln(l,'-120 rotate');
writeln(l,'newpath');
writeln(l,'0 0 moveto');
writeln(l,'sqrt3r 0 lineto');
writeln(l,'-300 rotate');
(*writeln(l,'% thirdaxis'); *)
writeln(l,'sqrt3r 0 lineto');
writeln(l,'closepath} bind def');
writeln(l);

writeln(l,'/squaresymbol { % x y side squaresymbol - (path)');
writeln(l,'/side exch def');
writeln(l,'translate');
writeln(l,'side 2 div neg dup translate');
writeln(l,'newpath');
writeln(l,'0 0 moveto');
writeln(l,'0 side lineto');
writeln(l,'side side lineto');
writeln(l,'side 0 lineto');
writeln(l,'closepath} bind def');
writeln(l);

writeln(l,'/linesymbol { % x1 y1 x2 y2 linesymbol - (path)');
writeln(l,'/y2 exch def');
writeln(l,'/x2 exch def');
writeln(l,'/y1 exch def');
writeln(l,'/x1 exch def');
writeln(l,'newpath');
writeln(l,'x1 y1 moveto');
writeln(l,'x2 y2 lineto');
writeln(l,'} bind def');
writeln(l);

writeln(l,'/boxsymbol { % x1 y1 x2 y2 boxsymbol - (path)');
writeln(l,'/y2 exch def');
writeln(l,'/x2 exch def');
writeln(l,'/y1 exch def');
writeln(l,'/x1 exch def');
writeln(l,'newpath');
writeln(l,'x1 y1 moveto');
writeln(l,'x2 y1 lineto');
writeln(l,'x2 y2 lineto');
writeln(l,'x1 y2 lineto');
writeln(l,'closepath');
writeln(l,'} bind def');
writeln(l);
end;
(* end module makelogo.marksymbols version = 9.01; (@ of makelogo.p 1999 April 2 *)

(* begin module startcosine *)
procedure startcosine(var l: text);
(* write the postscript definitions to make a cosine wave *)
(* example test:
% amplitude  phase  wavelength  base:
 -2.50000 cm  6.40000 cm  8.48000 cm  7.50000 cm
% xmin ymin xmax ymax step:
 -4.80000 cm  0.00000 cm 17.60000 cm 50.50000 cm 1
  0.5 cm 0.1 drawcosine
*)
begin
writeln(l);
writeln(l,'/degpercycle 360 def');
writeln(l,' ');
writeln(l,'/drawcosine {% amplitude  phase  wavelength  base');
writeln(l,'%              xmin ymin xmax ymax step');
writeln(l,'%              dashon dashoff dashoffset thickness');
writeln(l,'%              cosine -');
writeln(l,'% draws a cosine wave with the given parameters:');
writeln(l,'% amplitude (points): height of the wave');
writeln(l,'% phase (points): starting point of the wave');
writeln(l,'% wavelength (points): length from crest to crest');
writeln(l,'% base (points): lowest point of the curve');
writeln(l,'% xmin ymin xmax ymax (points): region in which to draw');
writeln(l,'% step steps for drawing a cosine wave');
writeln(l,'% dashon if greater than zero, size of dashes of the wave (points)');
writeln(l,'% dashon dashing on interval (points)');
writeln(l,'% dashoff dashing off interval (points)');
writeln(l,'% dashoffset offset for dashing (points)');
writeln(l,'% thickness if greater than zero, thickness of wave (points)');
writeln(l,'% use dashon and dashoff as blank and dashoffset as 0 for solid line');
writeln(l,'% See PostScrirt Language Reference Manual 2nd ed p. 500 on dash.');
writeln(l);
writeln(l,'  /thickness exch def');
writeln(l,'  /dashoffset exch def');
writeln(l,'  /dashoff exch def');
writeln(l,'  /dashon exch def');
writeln(l,'  /step exch def');
writeln(l,'  /ymax exch def');
writeln(l,'  /xmax exch def');
writeln(l,'  /ymin exch def');
writeln(l,'  /xmin exch def');
writeln(l,'  /base exch def');
writeln(l,'  /wavelength exch def');
writeln(l,'  /phase exch def');
writeln(l,'  /amplitude exch def');
writeln(l,'  % fun := amplitude*cos( ((-y-phase)/wavelength)*360) + base');
writeln(l,'  /fun {phase sub wavelength div degpercycle mul cos');
writeln(l,'           amplitude mul base add} def');
writeln(l);
writeln(l,'  gsave');
writeln(l,'    /originallinewidth currentlinewidth def');
writeln(l,'    thickness 0 gt {thickness setlinewidth} if');
writeln(l);
writeln(l,'    % Force the curve to fit into the region specified:');
writeln(l,'    newpath');
writeln(l,'    xmin ymin moveto');
writeln(l,'    xmax ymin lineto');
writeln(l,'    xmax ymax lineto');
writeln(l,'    xmin ymax lineto');
writeln(l,'    closepath');
writeln(l,'    clip'); (* stroke'); *)
writeln(l);
writeln(l,'    newpath');
writeln(l,'    xmin dup fun moveto');
writeln(l,'    % go to xmin-1 and xmax+1 to make sure we overlap the');
writeln(l,'    % next wave if there is one.  The clip above ensures that it');
writeln(l,'    % goes no further than requested. ');
writeln(l,'    % loop from xmin-1 to xmax+1 by step:');
writeln(l,'    xmin 1 sub step xmax 1 add {dup fun lineto} for');
writeln(l,'    % turn dash on if dashon is positive');
writeln(l,'    dashon 0 gt {[dashon cvi dashoff cvi] dashoffset setdash} if');
writeln(l,'    stroke');
writeln(l);
writeln(l,'    originallinewidth setlinewidth');
writeln(l,'  grestore');
writeln(l,'} bind def');
writeln(l);
end;
(* end module startcosine version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module cosine *)
procedure cosine(var afile: text;
                     amplitude: real;
                     phase: real;
                     wavelength: real;
                     base: real;
                     xmin: real;
                     ymin: real;
                     xmax: real;
                     ymax: real;
                     step: integer;
                     dashon: real;
                     dashoff: real;
                     dashoffset: real;
                     thickness: real);
(* write the cosine wave out to afile as defined by the parameters *)
begin
  writeln(afile, '% amplitude  phase  wavelength  base:');
  writeln(afile, ' ',amplitude:pwid:pdec, ' cm',
                 ' ',phase:pwid:pdec, ' cm',
                 ' ',wavelength:pwid:pdec, ' cm',
                 ' ',base:pwid:pdec, ' cm');
  writeln(afile, '% xmin ymin xmax ymax step:');
  writeln(afile, ' ',xmin:pwid:pdec, ' cm',
                 ' ',ymin:pwid:pdec, ' cm',
                 ' ',xmax:pwid:pdec, ' cm',
                 ' ',ymax:pwid:pdec, ' cm',
                 ' ',step:1);
  writeln(afile, '% dash settings:');
  write  (afile, ' ',dashon:pwid:pdec, ' cm');
  write  (afile, ' ',dashoff:pwid:pdec, ' cm');
  write  (afile, ' ',dashoffset:pwid:pdec, ' cm');
  writeln(afile, ' ',thickness:pwid:pdec, ' cm drawcosine');
end;
(* end module cosine version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module docosinewave *)
procedure docosinewave(var logo: text;{ params: parameters;}
                       wp: waveptr; (* define wave parameters *)
                       charwidth: real; (* width of characters *)
                       cmperbit: real; (* cm per bit *)
                       barheight: real; (* height of wave, cm *)
                       stacknumber: integer;  (* which logo stack we are on,
                          set to 1 if not doing multiple lines *)
                       position: integer; (* position in logo *)
                       walkerdirection: integer); (* walker direction *)
(* Overlay a cosine wave as specified by the parameters.
The wave goes the other direction if walkerdirection is negative.
This is done by negating the phase. *)
var
   xscale,yscale: real; (* converstion factors for x and y for the wave *)
   xmin,ymin: real; (* lower left corner the wave could be in, for the wave *)
   xmax,ymax: real; (* upper right corner the wave could be in, for the wave *)
   thiswave: waveptr; (* the wave we are currently printing *)
begin {with params do} begin
   thiswave := wp;
   while thiswave <> nil do with thiswave^ do begin
      xscale := charwidth;
      yscale := cmperbit;
      xmin := (position-stacknumber+1)*xscale; (* position *)
      xmax := (position+1)*xscale; (* position *)
      ymin := 0; (* bits *)
      ymax := waveamplitude + barheight*yscale; (* bits *)
      (* move back to the zero on the plot! *)
      writeln(logo,'gsave');
      writeln(logo,' ',-(position+1)*charwidth:pwid:pdec,
                     ' cm 0 translate');
      if extreme = 'h'
      then cosine(logo, (* high center point cosine wave *)
              +yscale*waveamplitude,             (* amplitude *)
              walkerdirection*xscale*(wavelocation+0.5), (* phase *)
              (* the half of a base is to make it put the
                 extreme in the middle of the character rather
                 than between characters *)
              xscale*wavelength,                 (* wavelength (cm) *)
              yscale*(wavebit-waveamplitude),    (* base (cm) *)
              xmin,ymin,xmax,ymax,      (* limiting box (cm) *)
              1, (* step is in points *)
              dashon, (* in cm *)
              dashoff, (* in cm *)
              dashoffset, (* in cm *)
              thickness) (* thickness is in cm *)
      else cosine(logo, (* low center point cosine wave *)
              -yscale*waveamplitude, (* amplitude *)
              walkerdirection*xscale*(wavelocation+0.5), (* phase *)
              xscale*wavelength,
              yscale*(wavebit+waveamplitude),
              xmin,ymin,xmax,ymax,
              1, (* step is in points *)
              dashon, (* in cm *)
              dashoff, (* in cm *)
              dashoffset, (* in cm *)
              thickness); (* thickness is in cm *)
{writeln(output,'walkerdirection:', walkerdirection:1);}
      writeln(logo,'grestore');
      thiswave := thiswave^.next
   end;
end; end;
(* end module docosinewave version = 12.45; (@ of lister.p 2016 Mar 16 *)

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

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

(* begin module postscriptheader *)
procedure postscriptheader(var a: text; title, creator: string;
                          llx: real; (* lower left x *)
                          lly: real; (* lower left y *)
                          urx: real; (* upper left x *)
                          ury: real  (* upper left y *)   );
(* Start writing postscript to file a.  This can be used to in conjunction
with makepageedges.  REQUIRES: postscript.const *)
begin
   writeln(a,'%!PS-Adobe-2.0 EPSF-2.0');
   write  (a,'%%Title: ');
   writestring(a, title);
   writeln(a,' ',version:4:2);
   write(a,'%%Creator: '); 
   writestring(a, creator);
   writeln(a);
   writeln(a,'%%BoundingBox:',
             ' ',round(llx):5,
             ' ',round(lly):5,
             ' ',round(urx):5,
             ' ',round(ury):5);
(*
BoundingBox values must be integer according to the Red book, page 234
             ' ',llx:5:1,
             ' ',lly:5:1,
             ' ',urx:5:1,
             ' ',ury:5:1);
*)
   writeln(a,'%%DocumentFonts:');
   writeln(a,'%%EndComments');

   (* 2005 Aug 6 Try to fool acrobat.  when an image is rotated 90
   degrees, Acrobat will reorient it.  STOOOOPPPPPIIIIDDD.  So use two
   45 degree rotations to avoid the problem.  Maybe some day this bug
   in Acrobat will be fixed tna the following will help.  For now it
   just provides a tad more control but does not solve the problem. *)
   (* 2005 Dec 22.  Sorry, can't do the following because
   then one CANNOT change the orientation in ghostview!
   writeln(a,'%%BeginDefaults');
   writeln(a,'%%PageOrientation: Portrait');
   writeln(a,'%%EndDefaults');
   writeln(a,'%%Orientation: Portrait');
   *)

   writeln(a,'/defaultllx ',defaultllx:5:1,' def');
   writeln(a,'/defaultlly ',defaultlly:5:1,' def');
   writeln(a,'/defaulturx ',defaulturx:5:1,' def');
   writeln(a,'/defaultury ',defaultury:5:1,' def');
   writeln(a,'/llx ',llx:5:1,' def');
   writeln(a,'/lly ',lly:5:1,' def');
   writeln(a,'/urx ',urx:5:1,' def');
   writeln(a,'/ury ',ury:5:1,' def');
end;
(* end module postscriptheader *)

(* begin module makepageedges *)
procedure makepageedges(var a: text);
(* write a postscript routine that shows where the edge of the page
is in red.  Anything touching this edge will not be printed.  Note
that the default llx, lly, urx, and ury must be defined elsewhere,
eg by postscriptheader. *)
begin
writeln(a,'/makepageedges {%');
writeln(a,'% draw a red line showing page edges based on the current');
writeln(a,'% page boundaries defined by');
writeln(a,'% defaultllx, defaultlly, defaulturx and defaultury');
writeln(a);
writeln(a,'/Xscreenupper 600 def');
writeln(a,'/Yscreenupper 800 def');
writeln(a);
writeln(a,'/newarea{');
writeln(a,'% make a clip path around the area');
writeln(a,'0 0 moveto');
writeln(a,'defaultllx defaultlly lineto');
writeln(a,'defaulturx defaultlly lineto');
writeln(a,'defaulturx defaultury lineto');
writeln(a,'defaultllx defaultury lineto');
writeln(a,'defaultllx defaultlly lineto');
writeln(a,'0 0 lineto');
writeln(a,'0 Yscreenupper lineto');
writeln(a,'Xscreenupper Yscreenupper lineto');
writeln(a,'Xscreenupper 0 lineto');
writeln(a,'0 0 lineto');
writeln(a,'clip');
writeln(a,'} def');
writeln(a);
writeln(a,'/printedge 2 def');
writeln(a);
writeln(a,'/bigger{');
writeln(a,'/defaultllx defaultllx printedge sub def');
writeln(a,'/defaultlly defaultlly printedge sub def');
writeln(a,'/defaulturx defaulturx printedge add def');
writeln(a,'/defaultury defaultury printedge add def');
writeln(a,'} def');
writeln(a);
writeln(a,'gsave');
writeln(a,'  newarea');
writeln(a,'  1 0 0 setrgbcolor');
writeln(a,'  fill');
writeln(a,'grestore');
writeln(a);
writeln(a,'gsave');
writeln(a,'  bigger');
writeln(a,'  newarea');
writeln(a,'  1 setgray');
writeln(a,'  fill');
writeln(a,'grestore');
writeln(a);
writeln(a,'} def');
end;
(* end module makepageedges version = 9.29; (@ of lister.p 1999 July 5 *)

(* begin module digitcounter *)
procedure digitcounter(var afile: text; var counter, previous: integer);
(* Make a digit counter on a single line.  The digits are written and
overwritten the next time by using control H.  To initialize, set the
'previous' variable to zero.  To terminate, put a
"writeln(afile,'whateveryouwant');".  If you put
"write(afile,'babble-counter: ');" before the call, the numbers will
show up on the same line and your message can indicate what the
counter is about. *)
const
   ordControlH = 8; (* the ordinal of control H so that we do not
      have to put an actual control H into the source code.
      The chr() of this will give the control H character *)
var
   digits: integer; (* number of digits in in previous number *)
   digitcount: integer; (* index to digits *)
begin
   if previous > 0 then begin
      (* backspace the PREVIOUS number of digits *)
      (* Compute the number of digits.  For sequencenumber = 1000, we
      add an extra 0.5 to avoid rounding that would give 3 instead of
      4 as the number of digits.  Other cases work fine with this. *)
      digits :=  trunc(ln(previous+0.5)/ln(10)+1);
{
writeln(output, digits:1, ' ', counter:1);
      for digitcount := 1 to previous do write(output, 'H');
}
      for digitcount := 1 to digits do write(output, chr(ordControlH));
{
writeln(output, digits:1, ' ', counter:1, ' ',previous:1);
}
   end;
   write(output, counter:1);
   previous := counter;
end;
(* end module digitcounter *)

(* begin module TESTdigitcounter *)
procedure TESTdigitcounter(maxcounter: integer);
(* test the digitcounter procedure *)
var
   counter: integer; (* counter number *)
   previouscounter: integer; (* previous counter number *)
begin
   counter := 0;
   write(output, 'counter number: ');
   while counter < maxcounter do begin
      counter := succ(counter);
      digitcounter(output, counter, previouscounter);
   end;
   writeln(output,' Voila!');
end;
(* end module TESTdigitcounter *)

(* begin module PatentMessage *)
procedure PatentMessage(var f: text);
(* Write the patent message to file f
version = 3.02 of PatentMessage_module 2017 Jul 31
*)
procedure makebar;
begin
writeln(f,
'**********************************************************************');
end;
begin
makebar;
writeln(f,
'* By downloading this code you agree to the Source Code Use License: *');
writeln(f,
'* https://alum.mit.edu/www/toms/Source_Code_Use_License_Schneider.txt *');
writeln(f,
'* Contact: https://alum.mit.edu/www/toms/contacts.html                *');
makebar;
end;
(* end module PatentMessage version = 5.66; (@ of prgmod.p 2017 Jul 31 *)

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

procedure help;
(* provide help to that poor confused person out there ... *)
begin (* help *)
writeln(output,'* help for prgmod');
writeln(output,'* prgmod is a library of modules.  each module does');
writeln(output,'* a particular thing that is useful for programming');
writeln(output,'* in various circumstances.  (hence the name prgmod.)');
writeln(output,'*');
writeln(output,'* prgmod is also a program, set up to test the modules');
writeln(output,'* and to give you an idea of what the modules do.');
writeln(output,'* there are four things to test and play with:');
writeln(output,'* 1. interactive input and output.  you may type any');
writeln(output,'*    sentence you want to, and prgmod will find');
writeln(output,'*    out the words in the sentence and show them to');
writeln(output,'*    you.  then it will do step 2:');
writeln(output,'* 2. the characters on the line will be sorted with a');
writeln(output,'*    very fast algorithm called a quicksort.  this');
writeln(output,'*    sort procedure is useful for sorting arrays.');
writeln(output,'* 3. if any word that you type begins with the letter n,');
writeln(output,'*    then the next two words are expected to be integers');
writeln(output,'*    for the beginning and end of a "numbar": a set of');
writeln(output,'*    numbers written vertically.  these are quite handy');
writeln(output,'*    for labeling the axis of a graph.  you may ask for');
writeln(output,'*    several numbars at once.  for example, type:');
writeln(output,'   numbar -5 15 n 90 105');
writeln(output,'*    to see that the program detects errors, try:');
writeln(output,'   not so good');
writeln(output,'*    and also:');
writeln(output,'   n 5 -5');
writeln(output,'* 4. if a word begins with a c, then you will be asked');
writeln(output,'*    for the radius of a circle - for testing real numbers');
writeln(output,'* 5. if # is given, the numberstring routine is tested');
writeln(output,'* 6. if p is given, the patent message is given.');
writeln(output,'* 7. if k 1000 is given, a counter will count to 1000.');
writeln(output,'*');
writeln(output,'* the only other commands are help and quit the program.');
end; (* help *)

begin (* prgmod *)
      writeln(output,'* prgmod ',version:4:2);
      PatentMessage(output);
      writeln(output,'* Start interaction by typing a Return.');
      writeln(output,'* Type "help" for instructions.');

      clearstring(buffer);
      repeat
         newline := false; (* we may still be using the old buffer line *)
         repeat
            if nostring(buffer) then begin
               writeln(output,'* prgmod');
               newline := true; (* we are starting a new line *)
            end;
            getchar(input, buffer, control, gotten);
         until gotten;

         if newline then begin (* we do this stuff only once per line *)
            writeln(output,'* ',buffer.length:1,' characters');
            writestring(output,buffer);
            writeln(output);


            (* reset current position, so tokens can be found: *)
            ourplace := buffer.current;
            buffer.current := 1;
            writeln(output,'* tokens on the line are:');
            gotten := true;
            while (buffer.current <= buffer.length) and (gotten = true) do begin

               gettoken(input, buffer, atoken, gotten);
               if gotten then begin
                  write(output,'(');
                  writestring(output, atoken);
                  write(output, ')')
               end;
            end;
            writeln(output);
            buffer.current := ourplace;


            (* demonstrate quicksort by sorting the
               the characters that the person typed *)
            writeln(output,'* sort the line:');
            setdemo(buffer, map);
            quicksort(1,buffer.length);
            print(output, buffer, map);
         end;

         if control = 'n' then begin
            (* demonstrate buffered input *)
            repeat
               if nostring(buffer)
                  then writeln(output,'* numbar: type the first number');
               getinteger(input,buffer,first,gotten);
            until gotten;
            repeat
               if nostring(buffer)
                  then writeln(output,'* numbar: type the second number');
               getinteger(input,buffer,last,gotten);
               if gotten then begin
                  if last < first then begin
                     gotten := false;
                     write(output,'the second number must be greater than');
                     writeln(output,' or equal to the first (',first:1,').');
                  end
               end
            until gotten;

            (* demonstrate numberbar *)
            spaces := 0;
            writeln(output);
            writeln(output,
               '* the numbar between ',first:1,' and ',last:1,' is:');
            numberbar(output,spaces,first,last,lines);
            writeln(output,'* ',lines:1,' lines used to print the numbar.')
         end;

         if control = 'h' then help;

         if control = 'c' then begin
            repeat
               if nostring(buffer)
               then writeln(output,'radius:');
               getreal(input,buffer,radius,gotten);
            until gotten;
            if radius < 0
            then writeln(output,'a negative radius is silly.')
            else writeln(output,'the area of a circle of radius ',radius:5:2,
                                ' is ',(3.14159*radius*radius):5:2)
         end;

         if control = '#' then numberstringtest(output);

         if control = 'p' then PatentMessage(output);

         if control = 'k' then begin
            (* demonstrate buffered input *)
            repeat
               if nostring(buffer)
                  then writeln(output,'* counter: type the a number');
               getinteger(input,buffer,first,gotten);
            until gotten;
            (* demonstrate counter *)
            TESTdigitcounter(first);
         end;

      until control = 'q';
      writeln(output,'quit');
1: end. (* prgmod *)
