program lister(book, listerp, features, colors,
               marks, list, map, output);
(* lister: list the sequences in a book with translation and sequence walkers

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

modules from: delman, delmod, prgmod
*)

label 1; (* end of program *)

const

superdebug = false; (* allow special debugging mode for figuring out
                       vertical colored bars *)
defaultdovertical = true; (* vertical mode *) {VVV}


(* begin module version *)
   version = 13.58; (* of lister.p 2022 Dec 19
2022 Dec 19: 13.58: seg fault in read defininitions and features
2022 Dec 16: 13.57: seg fault
2022 Dec 07: 13.56: new prgmod modules cause crash
2022 Nov 29: 13.55: test new prgmod modules from prgmod 5.76
2022 Nov 29: 13.54: using new prgmod modules
2022 Nov 25: 13.53: modules come from prgmod!!
2022 Nov 25: 13.52: groupnumber must be initialized!!!
2018 sep 19: 13.49: artmode black gets edge control
2018 Aug 16: 13.48: if stepvm crashr put '% halt' into map
2018 Aug 16: 13.47: if stepvm crashr put '% halt' into map
2018 Mar 15: 13.46: continue debugging vertical line bug
2018 Mar 15: 13.45: start debugging vertical line bug: install featurememoryptr.
-
The issue is that when there are two multi-part walkers whose zero
coordinates are to be printed at the same coordinate on the sequence,
the program is unable to record more than one at a time.  So it gets
lost and the vertical line gets broken and then the counts are wrong
and the vertical line keeps going down the page.
Specifically, the array for the vertical memory:
   featurememoryarray = array[1..linemax] of featurememory;
points to featurememory which does not allow more than one.
So the featurememory needs to be replaced with a linked list pointer:
featurememoryptr.
-
2018 Jan 24: 13.44: upgrade license
2017 Oct 10: 13.43: document listertimestamp
2017 Sep 29: 13.42: orf failed - why?
2017 Aug 08: 13.41: apply shiftsequence to vertical bars!
2017 Jul 31: 13.40: artmode black background mode!
2017 Jul 14: 13.39: namelength/linelength set to 200/210
2017 Jul 12: 13.38: namelength set to 200 to allow even longer names
2017 May 04: 13.37: 'total names not all used': allow run
2017 Mar 15: 13.36: modules upgraded from prgmod: no censor
2017 Feb 14: 13.35: featurenumber
2017 Feb 14: 13.34: move new modules back from prgmod.p - done!
2017 Feb 14: 13.33: move new modules to prgmod.p
2017 Feb 02: 13.32: upgrade PatentMessage
2017 Feb 02: 13.31: clear extra display for now
2016 Oct 31: 13.30: backup on 2017 Jan 30
2016 Oct 30: 13.29: failed for mkhindi SoR.  There is a section of code
                    that reverses the features - see featuresForward.
                    stepvm appears to depend on the order - sometimes?
                    solved but now getting lines
2016 Oct 26: 13.28: failed for mkhindi SoR
2016 Oct 15: 13.27: debug htmlink is finished
2016 Oct 14: 13.26: add fisprom example
2016 Oct 08: 13.25: backup
2016 Oct 08: 13.24: fis promoter fisp example still fails.
                    Program orf was not running with new groups.
                    I moved the lister modules and groupnumber to orf
                    Now it works!
2016 Oct 08: 13.23: clean up
2016 Oct 08: 13.22: clean up?
2016 Oct 08: 13.21: debug kevin's 169maptry2 SOLVED
                    If we are NOT keeping duplicates, then don't count
                    the duplicates for the vertical bar!
2016 Oct 07: 13.20: debug kevin's 169maptry2
2016 Oct 07: 13.19: debug kevin's 169maptry2
2016 Oct 06: 13.18: debug kevin's 169maptry2
2016 Oct 05: 13.17: debug kevin's 169maptry2
                    proximal-(36)-sigma38p10 2576585 Gap has no mothers
2016 Oct 03: 13.16: clean up
2016 Sep 30: 13.15: testing ... solved
2016 Sep 29: 13.14: debug: ~/work/multiscan/kevin/Estrem.Gourse1999/fig1
                    splitstring: clearstring(spointer^);
2016 Sep 28: 13.13: debug: ~/work/multiscan/kevin/Estrem.Gourse1999/fig1
2016 Sep 23: 13.12: ~/binding_sites/fis/fispromoter 'stepvm: f^.others = nil'
2016 Sep 22: 13.11: check/fix listerp upgrade path
                    listerp 10.45 does not fully upgrade to 13.09
                    upgrade horizontal/vertical bar documentation
2016 Sep 22: 13.10: remove halt at 'ILLEGAL call'
2016 Sep 16: 13.09: upgrade listerp to read parameters for vertical mode
2016 Sep 16: 13.08: clean up
2016 Sep 15: 13.07: further testing - success!
2016 Sep 15: 13.06: gap thread to the non-duplicate feature: SOR, SoR WORKS!!
2016 Sep 13: 13.05: thread duplicates the other way (failed)
2016 Sep 12: 13.04: not keep duplicates => thread mother gap anyway? worked!
2016 Sep 08: 13.03: 2test
2016 Sep 07: 13.02: enjoying the show! ... 2test fails in some cases still SOF
                    always count gaps as mothers!
2016 Sep 07: 13.01: ... clean up.  SoF fails, makes nibbins.  Unix fortune:
                    I've got a very bad feeling about this.
                    		-- Han Solo
                    but it works for the four cases: SoF, SoR, SOF, SOR !!!
2016 Sep 07: 13.00: ... got it! SoR works
2016 Sep 07: 12.99: almost there ...
2016 Sep 06: 12.98: get SoR to work - Reverse must detect gap
2016 Sep 05: 12.97: get SoR to work - Reverse must detect gap
                    to start vertical lines.  This can occur with
                    Forward too.
                    remove atafeature variable.
2016 Sep 05: 12.96: clean up
2016 Sep 05: 12.95: Showafeature revealed 2 gaps but no total!
                    solution: extra code in Threadgroup - removed
                    removed markismulti
2016 Sep 05: 12.94: one last black box from total line
                    cheat solution: StepVm: mothers less than zero set to zero
2016 Sep 05: 12.93: now extra vertical lines ... solved!
2016 Sep 05: 12.92: some vertical lines on p35 still missing
2016 Sep 03: 12.91: some vertical lines on p35 still missing
                    This happens when the walker is BELOW the color bar!
                    Setting sof to SoR shows the effect.
                    Setting sof to SOF shows the effect.
2016 Sep 03: 12.90: vertical lines ... clear old commented out code
                    docolorbar does the decay ... GOT IT!!!!!
2016 Sep 03: 12.89: vertical lines ...
2016 Sep 03: 12.88: vertical lines ... rebuild adding gaps to features
2016 Sep 02: 12.87: vertical lines ... four part model: 3 missing
2016 Sep 02: 12.86: vertical lines ... four part model: 3 missing
                    remove vertical ascii in art mode
2016 Sep 01: 12.85: vertical lines ... many cases working!!
2016 Sep 01: 12.84: debug multiple total parts: 4 parts case SOLVED
2016 Sep 01: 12.83: debug multiple total parts: 2 parts case SOLVED:
                    groupfeature := nil; in Threadgroup!!!
2016 Aug 31: 12.82: debug multiple total parts
2016 Aug 31: 12.81: continue vertical lines - remove junk code
2016 Aug 31: 12.80: continue vertical lines
2016 Aug 31: 12.79: continue vertical lines; clean up output
2016 Aug 31: 12.78: continue vertical lines; nextline
                    debugging = false removes numbers on verticals
2016 Aug 30: 12.77: attempt vertical lines
2016 Aug 30: 12.76: case of slid gap line
2016 Aug 30: 12.75: debug seg fault.  Probably:
                        gg^.mothers^.next := nil; (@ NEW 2016aug30 @)
2016 Aug 29: 12.74: ...
2016 Aug 29: 12.73: fix color bar direction in docolorbar
2016 Aug 25: 12.72: gap draw direction was multiscan bug!
2016 Aug 24: 12.71: work on gap draw direction
2016 Aug 24: 12.70: handle missing relcoo from scan program correctly
2016 Aug 23: 12.69: solve intermittent (!) segmentation fault
2016 Aug 23: 12.68: continue ... clean/tighten
2016 Aug 23: 12.67: continue ... clean/tighten
2016 Aug 23: 12.66: continue ... (clean up)
2016 Aug 23: 12.65: gap feature threaded - fixed order
2016 Aug 22: 12.64: gap feature threaded!
2016 Aug 22: 12.63: total feature threaded!
2016 Aug 19: 12.62: two factor group parts: name and relcoo.
2016 Aug 18: 12.61: new write feature definition
2016 Aug 16: 12.60: new write feature definition
2016 Aug 16: 12.59: backup
2016 Aug 16: 12.58: gap feature must thread only first and last {GgGzzz}
2016 Aug 15: 12.57: continue threading
2016 Aug 15: 12.56: continue threading (both features threaded into total!)
2016 Aug 15: 12.55: continue threading (first feature threaded into total)
2016 Aug 15: 12.53: THREAD GAP works!!!
2016 Aug 12: 12.52: read groups properly
2016 Aug 11: 12.51: read groups properly
2016 Aug 09: 12.50: tagging along for the gap reversal bug in multiscan
2016 Aug 09: 12.49: read group mark
2016 Aug 04: 12.48: group ids
2016 Jul 28: 12.47: check bar coordinate computations
2016 Mar 16: 12.46: get new readadefinition module from prgmod.p
2016 Mar 16: 12.45: clean up, move correction to prgmod.p
2016 Mar 16: 12.44: debug to fix reading "" definitions from multiscan
2016 Feb 26: 12.43: debug to fix vertical bar location
2016 Jan 24: 12.42: debug:
  sed -i.bak "s|'brightness = '|'brightness = ',|g" lister.p
2015 Aug 19: 12.41: wave must reverse when a feature reverses!  Use -phase.
2015 Feb 18: 12.40: Document colored text features
2015 Feb 11: 12.39: IHF marks objected to correctly
2014 Jun 23: 12.38: clean up - no code changes!  bug was in live (no 'p' mark)
2014 Jun 23: 12.37: first mark on complementary coordinate missed?
2013 Jun 10: 12.36: upgrade PatentMessage
2012 Oct 26: 12.35: fix coordinates in realpietoint!
2012 Oct 25: 12.34: backup
2012 Oct 25: 12.33: change 5 space mark to '.' - fivespacemark, tenspacemark
2012 Apr 18: 12.32: use ',' at 5 mark to avoid ambiguous: *138623230*
2012 Apr 16: 12.31: handle comments at end of marks file
2011 Sep 22: 12.30: upgrade Readdefinitionsandfeatures to count lines in prgmod
2011 Aug 24: 12.29: remove extra blanks
2011 May 02: 12.28: fix ftp links
2011 Mar 10: 12.27: new location
2011 Mar 10: 12.26: [] bracket around zero should NOT be on walker! - removed?
2011 Mar 04: 12.25: [] bracket around zero in list file
2010 Sep 08: 12.24: upgrade documentation on aastate -1
2010 Jan 27: 12.23: redo example file
2008 Sep 08: 12.21: emphasis and giveframes
2008 Aug 06: 12.20: bug: solved
2008 Aug 06: 12.19: bug: read last def before feature, not first.
2008 Aug 06: 12.18: bug: duplicate feature (cont)
2008 Jul 22: 12.17: bug: duplicate feature, equaldefinition
2008 Apr 22: 12.16: bug: lexA [even] model reports 3'->5' on complement
2008 Apr 22: 12.15: orientation check
2008 Apr 21: 12.14: ccrnp
2008 Apr 17: 12.13: increase Linemax to 1000 to allow wide ghostview
2008 Apr 17: 12.12: realpietoint bug
2008 Apr 16: 12.12: failed to show ygaD on complement
2008 Mar 11: 12.11: reading features handles no actual features.
2008 Mar 11: 12.10: multiscan giving no features gives segmentation fault
2007 Dec 26: 12.09: clean up
2007 Jun 04: 12.08: non CR mapcontrol is not accepted anymore.
2007 May 15: 12.07: horrors!  the color bar is now missing!
                    error introduced between 12.04 and 12.05 (fixed!)
2007 May 15: 12.06: correct empty features message
2007 May 07: 12.05: segmentation fault!  features are empty
2007 Apr 30: 12.04: duplicateprevious must be cleared!!
2007 Apr 18: 12.03: orf reading complement bug
2007 Apr 02: 12.02: prepare to move revised modules to pgrmod.p
2007 Mar 31: 12.01: clean up
2007 Mar 31: 12.00: introduce StopAtTotal mechanism
2007 Mar 27: 11.99: clear out testing code from markismulti (continued)
2007 Mar 27: 11.98: clear out testing code from markismulti (continued)
2007 Mar 27: 11.97: clear out testing code from markismulti
2007 Mar 27: 11.96: trace multiple gap part warning
2007 Mar 26: 11.95: clean up warning
2007 Mar 26: 11.94: clean up and speed the computation
2007 Mar 26: 11.93: implement ignoring duplicates - it works!!
2007 Mar 26: 11.92: reading features - don't remove duplicates.
                    Duplicate removal only happens at writing features
2007 Mar 20: 11.91: clean up cluster
2007 Mar 20: 11.90: debugging read of multipart features.
                    The new cluster mechanism functions AFTER all
                    features have been read in.  So it can identify
                    each gap or total and associate them only with the
                    features just before them.  That is, there are
                    clusters of features that get associated ONLY with
                    the right gap or total which follow immediately.
                    This solved the identificiation of the associated
                    features problem.
2007 Mar 17: 11.89: trigger ORFs on ttg start!
2007 Mar 17: 11.88: set emphasized orfs grey when there are no petals
2007 Mar 16: 11.87: adjust ORF strip height to be smaller.
                    goal: Mark active ORFs using ir features COMPLETED
2007 Mar 15: 11.86: clean up!
2007 Mar 15: 11.85: colored orfs matching ir walkers!
2007 Mar 15: 11.84: passing color parameters for orfs!
2007 Mar 15: 11.83: clean up!
2007 Mar 15: 11.82: convert '*' to colored rectangle - functional!
2007 Mar 15: 11.81: clean up
2007 Mar 15: 11.80: functionally finding ir to trigger aa frame!!
2007 Mar 15: 11.79: locating ir feature while in aa frame!
2007 Mar 15: 11.78: emphasis mechanism in place
2007 Mar 15: 11.77: add features to aminoacid lines, fix start bug
2007 Mar 15: 11.76: Mark active ORFs with emphasis (underscore _)
                    goal: Mark active ORFs using ir features! 444
2007 Mar 15: 11.74: put stopsigns on lister map if requested
2007 Mar 13: 11.73: reverse color bars: BAR REVERSAL
2007 Mar 05: 11.72: fix documentation ')'
2006 Oct 26: 11.71: bug: acrobat 7.0 display on the sun - overwriting
2006 Oct 20: 11.70: bug in letterrectangle - not solved.  HP printer
                    has a bug.  See technical notes.
2006 Oct 19: 11.69: working on bug in letterrectangle, removed extra calls
2006 Oct 19: 11.68: working on bug in letterrectangle, display problem
2006 Oct 14: 11.67: make duplicate definitions not fatal
2006 Oct 10: 11.66: bug: missing total line, 'duplicate definition'
2006 Oct 10: 11.65: modules readadefinition and Readdefinitionsandfeatures
                    moved to prgmod and back.
2006 Oct 10: 11.64: clean up output
2006 Oct 10: 11.63: bug in markismulti: forgotten clearstring!
2006 Sep 14: 11.62: lower bound on xmulfactor in boxshow
2006 Jun 07: 11.61: makerectangle: no clip so that edge has width!
2006 May 09: 11.60: bug: outline of characters failed in PDF
                    see: OUTLINE of characters
2006 Apr 17: 11.59: bug: gs crash in letterrectangle: stack underflow
                    solution: get the PARTS of the FontBBox array.
2005 Dec 22: 11.58: upgrade petal definition
2005 Dec 22: 11.57: clip edge of petal; allow -1 petal to remove edge.
2005 Nov 09: 11.56: bug left residue in list file
2005 Nov 09: 11.55: implement outline parameters
2005 Nov 09: 11.54: boxshow does outlines around characters
2005 Nov 09: 11.53: improve marks warning more.
2005 Nov 09: 11.52: when marks are not completed, give more info
2005 Oct 27: 11.51: letterrectangle incorrectly called, fixed.
2005 Sep 28: 11.50: multiple features for Gap : improve warning
2005 Sep 28: 11.49: bug: multiple features for Gap end must distinguish
                    not only by their position but also by their name.
2005 Sep 20: 11.48: cleanup
2005 Sep 20: 11.47: if no petals, horizontal bar should not be black
2005 Sep 20: 11.46: remove 'the feature orientation was not consistent'
                    halt in failOrientation;
2005 Sep 20: 11.45: continue adding superdebug mode
2005 Sep 20: 11.44: introduce superdebug mode
2005 Sep 15: 11.43: upgrade linelength
2005 Sep 15: 11.42: upgrade from 9.92 corrected
2005 Aug  4: 11.41: globaldebug for prgmod routines.
2005 Aug  4: 11.40: protection in docolorbar against no 'others'
2005 Jul 12: 11.39: bug, 'digit expected after sign'
                     in proc init'lz then r'dparameters
                     upgrade to 10.45 was wrong, needs 22 lines.
2005 May 23: 11.38: upgrade patent message
2005 Feb  5: 11.37: locatesubfeatures allows reuse of one model
2005 Jan 25: 11.36: todo: censor the start material for fusing figures
2005 Jan 18: 11.35: remove ',' from with statments using 'do with'
2005 Jan 14: 11.34: output patent message
2004 Dec  5: 11.33: resolve GPC compile bug  [see 2005 jan 18]
2004 Sep  3: 11.32: left edge of total missing vertical mark
2004 Sep  2: 11.31: left edge of total missing vertical mark ellipsis
2004 Sep  2: 11.30: left edge of total missing vertical mark
2004 Sep  2: 11.29: left edge of total missing vertical mark
2004 Aug 19: 11.28: left edge of total missing vertical mark
2004 Aug 19: 11.27: left edge of total missing vertical mark
2004 Aug 16: 11.26: left edge of total missing vertical mark
2004 Aug 16: 11.25: left edge of total missing vertical mark
2004 Aug 16: 11.24: left edge of total missing vertical mark
2004 Aug 15: 11.23: left edge of total missing vertical mark
2004 Aug 15: 11.22: left edge of total missing vertical mark
2004 Aug 15: 11.21: cleanup
2004 Aug 15: 11.20: clear the display - vertical lines functional!!!!
2004 Aug 15: 11.19: walkermemory debugging - functional!!
2004 Aug 14: 11.18: time to protect walkers from vertical memory!
2004 Aug 14: 11.17: another Stepvm bug - solved, eliminate setverticalmemory
2004 Aug 14: 11.16: Stepvm all cases now displayed!
2004 Aug 14: 11.15: Stepvm missing some cases
2004 Aug 14: 11.14: Stepvm missing some cases; checkcount
2004 Aug 14: 11.13: Stepvm steps down with values > 2
2004 Aug 14: 11.12: markismulti counts mothers and others correctly
2004 Aug 14: 11.11: markismulti call was in wrong place in Readdef...
2004 Aug 14: 11.10: debug verticalmemory
2004 Aug 14: 11.09: debug verticalmemory - total missed
2004 Aug 14: 11.08: set verticalmemory based on both mothers and others
2004 Aug 13: 11.07: markismulti problem solved
2004 Aug 12: 11.06: markismulti problem
2004 Aug 12: 11.05: prgmod changes
2004 Aug 12: 11.04: replace prgmods
2004 Aug 12: 11.03: writefeatures renamed writethefeatures
2004 Aug 11: 11.02: multiple mothers allowed using feature carriers
2004 Aug 10: 11.01: more debugging
2004 Aug 10: 11.00: vertical bars functional!
2004 Aug 10: 10.99: bug: vertical black bars
2004 Aug 10: 10.98: gap and total grey line for their strength!
2004 Aug 10: 10.97: letterrectangle height width control
2004 Aug 10: 10.96: continue vertical mode surgery: total grey control
2004 Aug 10: 10.95: continue vertical mode surgery
2004 Aug 10: 10.94: continue vertical mode surgery: computeacolor
2004 Aug 10: 10.93: code rearranged to put standard modules on top
2004 Aug 10: 10.92: continue vertical mode surgery
2004 Aug 10: 10.91: continue vertical mode surgery: functional!
2004 Aug 10: 10.90: continue vertical mode surgery (vertical bars up)
2004 Aug 10: 10.89: continue vertical mode surgery (quite good!)
2004 Aug 10: 10.88: continue vertical mode surgery (partially functional)
2004 Aug  9: 10.87: continue vertical mode surgery
2004 Jul 29: 10.86: scaleimage zero disallowed
2004 Jul 29: 10.85: vertical mode vmmax set to actualmax ... EXACTLY
2004 Jul 29: 10.84: vertical mode now shows up on walkers
2004 Jul 29: 10.83: vertical line affects length of line written out
2004 Jul 29: 10.82: showrecordeddata
2004 Jul 29: 10.81: cleanup;
2004 Jul 29: 10.80: investigate vertical memory
2004 Jul 28: 10.79: functional, removed vertical marks
2004 Jul 28: 10.78: saturation fades along the gap feature!
2004 Jul 28: 10.77: hue fades along the gap feature!
2004 Jul 28: 10.76: integerate feature pointing with colorbar:
                    hues captured from features at ends of Gap feature!
2004 Jul 28: 10.75: features now point to other features!
2004 Jul 28: 10.74: markismulti works with features, not definitions
2004 Jul 28: 10.73: forwards
2004 Jul 28: 10.72: cleanup
2004 Jul 28: 10.71: from prgmods: features now have others list.
2004 Jul 28: 10.70: horizontalmemory ...
2004 Jul 28: 10.69: horizontalmemory ... spectrum on the bar!
2004 Jul 28: 10.68: horizontalmemory ... at least it writes something ...
2004 Jul 27: 10.67: horizontalmemory ... ends of ismulti function!
2004 Jul 26: 10.66: verticalmemory ... started
2004 Jul 26: 10.65: integerate ismulti; verticalmemory states set
2004 Jul 26: 10.64: integerate isgap, istotal
2004 Jul 26: 10.63: isgap, istotal part of feature definition
2004 Jul 26: 10.62: next aim: make multiscan bars in color: igap, istotal
2004 Jul 23: 10.61: cleanup
2004 Jul 22: 10.60: stabilized version
2004 Jul 22: 10.59: both text petal arrows working
2004 Jul 22: 10.58: mysterious halt
2004 Jul 22: 10.57: debug cooway again
2004 Jul 22: 10.56: text petal arrows!
2004 Jul 22: 10.54: implement text petal thickness - functional!
2004 Jul 21: 10.53: implement text petal thickness (continued)
2004 Jul 21: 10.52: implement text petal thickness
2004 Jul 21: 10.51: begin to implement text petal thickness
2004 Jul 21: 10.50: colorrectangle -> petal
2004 Jul 21: 10.49: cleanup
2004 Jul 21: 10.48: prgmod fix: read features without any params.
2004 Jul 21: 10.47: cleanup, document
2004 Jul 21: 10.46: artmode name mode
2004 Jul 20: 10.45: artmode introduced
2004 Jul 20: 10.44: cleanup
2004 Jul 20: 10.43: functional ascii petals!!
2004 Jul 20: 10.42: currentfont /FontBBox get pstack
                    /fbmx currentfont /FontMatrix get def
2004 Jul 20: 10.41: further debugging ... Functional ascii color!
2004 Jul 20: 10.40: cleaned up. spitoutblanks
2004 Jul 20: 10.39: modifiy setcoordinates: walkers use old method
                    because they need sequence coordinate data;
                    ascii features ignore it.
2004 Jul 20: 10.38: further debugging.  The bug is that lister
                    is sensitive to the pie^.key.coodir.
                    If pie^.key.coodir is negative, ascii features
                    are placed backwards.
2004 Jul 19: 10.37: document fispromoter.pdf
2004 Jul 19: 10.36: full control of color of ascii background lines!
2004 Jul 19: 10.35: full control of color of ascii background lines!
2004 Jul 19: 10.34: control of color of ascii background lines
2004 Jul 19: 10.33: setting up color of ascii background lines
2004 Jul 19: 10.32: Tparam etc reading works.
2004 Jul 17: 10.31: hsb controls for non-matrix features
2004 Jul 16: 10.30: introduce mkcrf script
2004 Jul 14: 10.29: cleanup
2004 Jul 14: 10.28: color rectangle: site strength control, integrate
2004 Jul 14: 10.27: color rectangle: site strength control! variables found
2004 Jul 14: 10.26: documentation for color rectangle
2004 Jul 14: 10.25: documentation for color rectangle
2004 Jul 14: 10.24: only warning if no definition for color rectangle
2004 Jul 13: 10.23: cleanup
2004 Jul 13: 10.22: walker color rectangle background is FUNCTIONAL!
2004 Jul 13: 10.21: much of the read mechanism for walker colors done
2004 Jul 13: 10.20: walker colors: hsb or rgb functional
2004 Jul 13: 10.19: boxes on walkers functional!
2004 Jul 13: 10.18: boxes on walkers partially implemented
2004 Jul 13: 10.17: boxes on walkers partially implemented
2004 Jul 13: 10.16: more detail on boxes on walkers
2004 Jul  9: 10.15: prgmod upgrade, considering boxes on walkers
                    would need edgebox etc from marks.arrow
2004 Feb  6: 10.14: clean up
2004 Feb  6: 10.13: page forwards works but pages blank on going back
                    A gsave/grestore for the ENTIRE file, tag:
                    % allows embedding entire figure
                    These block going back.  DO FOR EACH PAGE!
                    solution:  put calls in startpage and (new) endpage
2004 Feb  6: 10.12: stack bug: pop needed in MB definition
2004 Feb  6: 10.11: segmentation fault: needed to init pie pointer for getocp
2004 Feb  6: 10.10: bug: stack is filling and crashing
                    add space in front of page number mark
                    in writepagenumber
2003 Sep  8: 10.09: gsave/grestore around entire map for embedding
2003 Aug 18: 10.08: 'h' in features means an earlier program halted.
2001 Sep  5: 10.07: upgrade page boundaries
2001 May  3: 10.05: add link to Delila Tutorial
2001 May  3: 10.04: remove b-ubba on page :-)
2001 May  1: 10.03: allow having no sequence (to show just walkers)
2001 Feb 22: 10.02: correct the documentation on edgecontrol
2001 Feb 22: 10.01: resolve both bugs {bbb2002Feb22}
2001 Feb 22: 10.00: bug fix of Sep 7 means exon ends lost!
2002 Feb 18: 9.99: correct upgradeto992: pageedges before edgecontrol
2001 Oct  4: 9.98: number parameters as line numbers
2001 Sep  9: 9.97: clean up code
2001 Sep  7: 9.96: bug fix: lost features after coordinate jump
2001 Aug 30: 9.95: total edgecontrol, as in alist
2001 May 24: 9.91: shiftsequence: was not shifting right by two-fold
2001 May 23: 9.90: missing feature definition bug
2001 Mar 11: 9.89: spelling correction
2001 Mar  8: 9.88: warn if marks file was not finished
2001 Jan 31: 9.86: fix bug by removing use of ee in doshift; use MB instead
2001 Jan 17: 9.85: spaces between numbers fixed for pdf
2001 Jan  5: 9.81: bug: pdf font compression of '()-' solved
2001 Jan  4: 9.77: GPC compatable
2001 Jan  4: 9.76: bug: many spaces don't convert to pdf; see writefeatures
2000 Nov 14: 9.74: fix stopsign spacing when codelength=3 in aawritecolor
2000 Nov 10: 9.73: standardize listerp and listerxp
2000 Oct  9: 9.72: orientation bug fixed by prgmod upgrade
2000 Oct  1: 9.71: N and n described for page trigger
2000 Sep  2: 9.68: marksorder: control of when marks are written.
2000 Jul 30: 9.66: fix readwaveparameters module
2000 Jul 23: 9.63: make compatable with gpc (gnu pascal compiler)
2000 Jul 23: 9.62: upgrade to new iworgchr in delmod
2000 Jun 28: 9.61: user definitions go into preamble!
2000 Jun 14: 9.58: bug in writetheline - died when actualmax=0; if stmt fixes.
2000 Jun 14: 9.57: duplicate definitions bug solved in prgmod source.
2000 Jun 14: 9.56: flag duplicate definitions but just use the first one
2000 May 30: 9.54: protect against pocld being l with no numbers on next line
2000 Mar 22: 9.53: bug resolved by revising getbase in delmod
                   move getbase below piecelength
2000 Mar 22: 9.52: libdef.test gives a segmentation fault!
2000 Jan  3: 9.50: explain listerx
1999 Sep  6: 9.49: mention mkbookfeatures
1999 Aug 16: 9.48: Upgrade to prgmod for Readdefinitionsandfeatures
                   to bypass duplicate problems for now.
1999 Aug 14: 9.47: duplicate definition causes unknown trouble
1999 Jul  5: 9.28: feature parts are all standard strings, quotestrings gone.
1999 Jun  9: 9.21: duplicate features removed better, based on symmetry.
1999 May  8: 9.14: the barger bug is solved!
1999 May  4: 9.12: page number control added
1999 Apr  1: 9.00: named objects from search can have italics
1999 Mar 31: 8.99: down box colors can be reprogrammed in marks
1999 Mar 11: 8.79: put cosine wave on each walker.
1999 Mar  4: The marks file p function was implemented.
1999 Feb 11: first number gets page number (except with q option)
1998 Jan 26: namelength set to 100 to allow long names
1997 June 8: NKFC addition to HOPI controls.
1997 Apr 18: 8.40: ribl handles negatives so purple and black boxes
     now can mark below lowerbound and negative infinity respectively.
1997 Apr 12: 8.26: ribl definition changed to be minribl to maxribl.
     This simplifies the code and prevents bugs.
1996 Oct 9: full page control by book piece numbers
1996 Jun 15: sideways characters implemented
1996 Jun: add long names to piece info.
1996 May 30: automatically remove duplicate sites
origin:  probably around 1980 *)
updateversion = 13.09; (* defines lowest acceptable current parameter file *)
previousupdateversion = 11.55; (* previous updateversion *)
versionupperbound = 20.00; (* highest version that will be accepted *)
(* end module version *)

(* begin module describe.lister *)
(*
name
   lister: list the sequences in a book with translation and sequence walkers

synopsis
   lister(book: in, listerp: in, features: in, colors: in, marks: in,
          list: out, map: out, output: out)

files
   book: Any book generated by the Delila system.

   listerp: Parameters to control the listing.  If listerp is empty, default
      values are used.  Otherwise, the file must contain the following
      parameters, one per line:

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

      2. basesperline: the number of bases per line in the listing.  Note that
         besides margin characters, there will be one blank with each base.
         This must be a multiple of 3 whenever one is printing amino acids.

      3. aastate: the mode for listing amino acids:
         0 = none
         1 = predict peptides starting at aug, gug or uug.
             show nonsense codons.  uug is new as of 2007 Mar 16.
         2 = translate all frames

         In the special case that predicted reading frames starting at
         identified ribosome binding sites are emphasized, the
         predicted peptides outside the emphasized frame are
         suppressed.  To get these anyway, use the negative value of
         this parameter.  That is, use aastate = -1 or -2.  (The
         variable is called giveframes.)

      4. frameallowed: an integer in the range 0 to 7.  The binary
         representation of this number determines which amino acid frames are
         allowed to be printed.  The highest bit is the highest printed frame.

      5. codelength: Amino acid code: one character
            1 = 1 letter code
            3 = 3 letter code

      6. seqlines: an integer that controls the listing of the sequence.
            0 = no sequence (but show amino acids and sequence numbering)
            1 = show sequence
            2 = show sequence and complement underneath

      7. pageaction:  one character
            c = computer defined page character (often will be a control-L)
            l = LaTeX document page notation
            n = no page marks

      8. pagelength (integer): the number of lines per page.
         This will determine when lister starts a new page.  When displayed
         by ghostview, it has the nice property of showing only the
         number of lines given, so the display can be 'shrinkwrapped' around
         the interesting features.  See the pageedges parameter.

      9. "hopi": Header control: The first 4 characters of the line are "hopi"
         (in that order).  These define the parts of the list to show:
            header: version number program name, etc.
            organism/chromosome name
            piece information
            index
         The characters are either lower case (do not display) or upper case
         meaning to display.  For example, hoPi would only give the piece
         information.  Special case: if the first letter is 'B' then only
         the book date and title will appear in the header.

         The next 4 characters on the same line, NKFC, control the
         parts of the piece information to display:
             N: number (the word 'piece' will proceed it)
             K: key name (eg, GenBank accession)
             F: full name (this can be controlled by the Delila name command)
             C: coordinates of the piece
         As with hopi, only upper case letters turn on the option.

     10. "ndaf": data control: The first four characters of the line define
         the lines of data to show.  The possible characters are:
            N  show numbering of DNA sequence
            D  show DNA sequence
            A  show amino acid sequence
            F  show features
         These may be presented in any order.  Capital letters turn on the
         feature, small letters turn it off.  No other characters are
         allowed.

     11. "sof": feature position control: three characters on the line.

         If the first character is an upper case 'S' (same line) then the
         features that run from one line to the next are always the SAME
         distance from the sequence.  Reasoning: For each line of the
         sequence the features are written in the order they are found in
         the features file.  When there is space available, features are put
         closer to the sequence.  If a feature continues on the next line,
         it will often be a different distance from the sequence.  One way
         to avoid this would be to make a long line and then use the split.p
         program.  This parameter avoids that step.  Otherwise, the features
         are placed as close to the sequence as possible.

         If the second character is an upper case 'O' then only ONE feature
         is put on each line.  Note that this alone does not guarantee that
         features will remain on the same line.

         WARNING: if a plot is very complicated, the ellipsis' on one line
         will not be in the same order as the next line.  In these cases it
         is better to use 'S' or turn on 'O'.

         If the third character is an 'F', then features are placed in the
         order ("FORWARD") given in the features file.  If this character is
         an 'R' features are placed in the REVERSE order.  (This is
         implemented simply by reversing the list.)  To see the effect of
         this, consider a series of features that saturate the sequence, one
         every base.  For simplicity, set the ONE feature per line mode on
         (see above).  In the Forward mode, the first feature would appear
         on the "upper left" and successive ones would appear towards the
         "lower right" as in the backslash "\".  In the Reverse mode, the
         first features would appear on the "upper right" and proceed to the
         "lower left" as in the slash "/".

     12. pagetrigger:  Pages are normally started when the list goes beyond
         the pagelength.   If the first character on this line is 'p' then a
         new page will start every time a new piece of DNA is encountered in
         the book (actually it will when the organism/chromosome information is
         to be put out).  If the first character is 'o' or 'c' the trigger will
         be at the organism or chromosome changes, respectively.  Other
         characters leave triggering at the end of the normal page.
         The action take at the end of the page is determined by pageaction.

         If the pagetrigger is 'l', then the next lines list the numbers of
         pieces in the book that should trigger paging.  This allows
         arbitrary numbers of pieces per page, under program control.
         The list is started with a delimiter number.  This number must
         be also at the end of the list.  For example if there are no
         pieces numbered 0, one could make the list with "0 3 5 7 0",
         which would put pieces 1 and 2 on the first page, 3 and 4 on
         the second page, etc.

         Doubling: if the pagetrigger is 'd', paging occurs on odd
         piece numbers.  This is the same as l but without the list.
         The equivalent l list would be like: "0 3 5 7 0".

         Capital letters for any of pocld will prevent page numbers but
         otherwise will page as before.

         To prevent page triggering, use a space.
         To make no page number on the first page use N.

     13. map control: A series of values:
         * mapcontrol: If the first character on the line is a 'C', then the
           color map file will be written.  If it is 'R' then the page will
           be set up so that the upper left corner is moved to the lower left
           corner and the image is rotated 90 degrees counter clockwise.
           This has the effect of making the image in "landscape" mode.

         * fontsize (integer): The character height in points (there
           are 72 points/inch, 2.54 cm/inch).  Typical values: 10 or 12.

     14. image positioning controls
         * deltaXcm: The amount to move the image in X (cm).
         * deltaYcm: The amount to move the image in Y (cm).
         * scaleimage: the scaling factor.

         The image will be shifted on the printed page.  X is positive to the
         right and Y is positive up the page.  Generally one would use
         positive values for X and negative values of Y since the image
         should otherwise fit snugly in the upper left corner of the page.
         When the "shrinkwrap" mode is on (see parameter pageedges below) the
         position will have no effect on viewing by GhostView but the image
         will still move around on the printed page.  This is quite
         convenient because it means that one can position an image on the
         printed page as one would like independently of the display on the
         computer screen.

         The scaling is performed after movement from the upper left hand
         corner of the image as one would read it.  If the image has been put
         in "landscape" mode the delta-shifts are given in the new coordinate
         system.  This allows one to switch between "landscape" and regular
         "portrait" mode without changing the parameters, and it allows one
         to think in terms of a normally held page.

     15. lowerbound: The lower bound of the walker display box, in bits.  It
         must be negative.  See figurebottom.

         If a base goes below lowerbound, Lister clips the letter to
         lowerbound and puts a purple box.

         If a base has never been seen before at a position in a binding
         site, then Lister shows a black box.

     16. figurebottom: How far down the bottom of the walker display is, in
           bits.  It must be negative.  See lowerbound.

         Lowerbound is for displaying the box at the zero coordinate of the
         walker, while figurebottom controls the number of lines the bottom of
         the walker will take up (1 line = 1 bit).  By separating these two
         functions the user has more control over the display.

     17. shiftsequence (integer):  The sequence will be shifted to the right
         by this many bases.  It must not exceed basesperline.  Shifting left
         is done with Delila instructions by removing sequence.  This allows
         one to make figures with the sequences lined up as one would like.

     18. pageedges pageboundaries extraright (character, character,
         integer):  The size of the map page shown in GhostView is
         determined by these parameters.

         pageedges (character):
            If the first character is 'd' then default values are used that
            show the region that will be printed on a standard printer.  See
            technical notes for further details.

            If the first character is 's' then the program will "shrink wrap"
            the page to fit the parameters basesperline and pagelength.

         pageboundaries (character): If the second character is 'b' then the
            program will show the default page boundary as a red line running
            around the page.  If any graphics touches this red line, it will
            not appear on the printer.

         extraright (integer): Since header lines and features can extend to
            the right, the integer defines the number of extra characters to
            allow for on the right side of the page.

     19. edgecontrol edgeleft, edgeright, edgelow, edgehigh:
          edgecontrol is a single character that controls how the bounding
          box of the figure is handled.  If it is 'n' then the bounding box
          will be the page parameters defined in constants inside the program
          (llx, lly, urx, ury AND changes as set by the previous parameter
          line).  If the parameter is 'p', there are four real numbers that
          define the edges around the clist in cm.  To allow a map to be
          imbedded into another figure, its size must be defined in
          PostScript (with %%BoundingBox).  By setting these four numbers,
          the edges are defined.  Negative values are allowed, so one may
          move the edges as desired.

          These parameters are the same form as those in the alist program.
          The definitions are IN ADDITION to the parameters on the previous
          line.  Thus pageedges d and s on the previous line still give the
          default page and the shrink wrap.  The extraright in the previous
          parameter line is in CHARACTERS so that one may control the right
          edge precisely.  By contrast, the edgeright of this parameter line
          (and all others) is in cm.

          (New as of 2001 Aug 29)

     20. KeepDuplicates (character): if the first character on the line is a
         'k', duplicate features will be kept.  If not, duplicates will be
         eliminated.  One use of duplicate features is in a "supporting"
         role:  by putting a feature that prints as a blank space in the
         location of a visible feature, that visible feature will be forced
         further down the page.  This gives one more control over the
         placement of features, but if one is using a lot of supporting blank
         features, then they must not be eliminated by the program as
         duplicates.

         Duplication is defined as having the same id, position and
         orientation.

     21. Sideways (character): if the first character on the line is an 's',
         asymmetric walkers will be shown with sideways characters.  The
         direction of the walker is the direction that one would read the
         letters "down the page".

     22. MinimumLines (integer):  This number defines the minimum number of
         lines between sequences.  It is intended to be used in cases where
         one wants to compare a page of sequence to another page that has a
         slightly different sequence.  Features will appear or disappear and
         so normally the number of lines used will vary.  This is not good if
         one wants to make a movie or compare two sequences.  By setting
         minlines high enough, one can ensure that the locations of the lines
         will not vary.

     23. artmode (character):  if the first character on the line is
         an 'a', then all black ASCII characters on features are
         removed.  This mode has become possible because features can
         now be displayed with sequence walkers and colored boxes for
         ASCII features.  If the character is 'n' then names will be
         given and objects that have no color will be given.  If the
         character is 'b' the art mode is activated and the background
         becomes black.  One pixel is provided around the standard
         boarder (llx, lly, urx, ury).  If the character is 'B' the
         art mode is activated and the user can use the edge control
         to change where the black is.

     24. outline (character), outlinewidth (real) outlinegray (real)

         If the first character is 'o' then the letters of each
         sequence walker will have an outline around them.

         The second parameter determines the stroke width.  0.0 will
         give 1 pixel wide (as defined in PostScript).  1.0 may be too
         wide, but real values in between, such as 0.3, seem ok.  The
         letter is clipped, so only half of the stroke width is
         actually drawn.  If one uses a large value, then the entire
         letter becomes filled in, providing a way to make walkers
         that are entirely shades of gray.

         The third parameter is the gray scale value to use for the
         outline.  0 is black and 1 is white.  (There is no option for
         color.)

         The reason for allowing this option is that when petals are
         used, a very strong site can have a petal rectangle that is
         the same color as a sequence walker letter.  For example, the
         default petal color is red and the default color for the base
         t is also red.  When the petal is under a strong binding
         site, all of the t's are invisible against the petal
         background.  By making an outline, the letters can be
         distinguished from the background, but at the expense of them
         becomming thinner.  Beware that with some printers it may not
         be possible to see outlines that are too thin.

         (New as of 2005 Nov 9.)

     25. horizontal (character) symbol (character) width (real) height (real)

         If the first character is h, then provide a colored bar
         for the Gap connection lines.

         The second character, the symbol for the horzontal line is
         ignored.  It is there only for consistency with the vertical
         control.  The feature symbol is controlled in the feature itself
         and this does not override.

         The width and height are scale factors from a standard
         colored bar.  Leave them as 1.0 and 1.0 to get the standard.

         Example:
         h+ 1.0 1.0 horizontal: h(orizontal bar) - width height

     26. vertical (character) symbol (character) width (real) height (real)

         If the first character is v, then provide vertical colored
         bars in multipart walkers.

         The second character is the symbol for the vertical line.  If
         you set it to space (' ') then there won't be one.

         The width and height are scale factors from a standard
         colored bar.  Leave them as 1.0 and 1.0 to get the standard.

         Example:
         v| 1.0 1.0 vertical: v(ertical bar) | width height

   features: A list of locations of binding sites and other features.  Lines
      that begin with "*" are comments.  Completely blank lines are
      skipped.  Otherwise each line defines the location or properties
      of a site.

      * comment
      d definition of a feature
      r ribl matrix
      b boundary for site
      c color rectangle
      @ location of a feature

      g beginning of a multi-part group of features

      For example, to generate

    *260      *         *270      *         *280      *         *290
 5' t t a t c c a c a g t a g a t c g c a c g a t c t g t a t a c 3'
          [------*------0-----^---> Site Positive 270
              <---v-----0------*------] Site Negative 270
                              [------*------0-----^---> Site Positive 280

      one uses the four lines:

      define "Site" "-" "<v0*]" "[*0^>" -7 -3.5 0 +3.0 +5
      @ K01789 270 +1 "Site" "Positive 270"
      @ K01789 270 -1 "Site" "Negative 270"
      @ K01789 280 +1 "Site" "Positive 280"

      The first line defines a site called "Site".

                "-": use dashes to pad out the feature background.
            "<v0*]": the characters to use in the negative orientation
            "[*0^>": the characters to use in the positive orientation
  -7 -3.5 0 +3.0 +5: the location of the characters relative to the zero
                     coordinate of the binding site.

      The background string must contain only 1 or 2 characters.  The
      character mark strings may be any length (up to a limit defined in the
      program), must be the same length, and that length must correspond to
      the number of numbers that follow.

      If the second character in the background string is "d", then the
      background will be the DNA sequence and the spaces between the
      sequence will be the first character.  The complementary base is given
      when the feature orientation is negative.  Note if one puts marks on
      the feature at the half base positions, they will not interfere with
      the sequence.

      If the second character in the background string is "w", then the walker
      will be displayed.  This consists of characters with varying heights that
      represent the sequence conservation of the given base, measured in bits.
      A "W" will show the bounding box on each walker character.  The
      complementary base is given when the feature orientation is negative.

      If this character is l, it acts as "w" but shows lines at integer
      values of the bits.

      If this character is L, it acts as "W" but shows lines at integer
      values of the bits.

      If this character is i, it acts as "w" but shows lines at integer
      values of the bits only on the walker.

      If this character is I, it acts as "W" but shows lines at integer
      values of the bits.

      The second line in the example above (beginning with "@") defines the
      location of a binding site on sequence K01789.  The zero of the site
      is placed at coordinate 270.  The feature is to be oriented in the
      positive direction relative to the given sequence.  The name of the
      site is "Site".  Additional information to be listed about the site is
      "Positive 270".

      The site will be marked every time it is found, even there are
      multiple copies of a piece by the same name in the book.  Sites which
      extend outside the line are listed with the ellipsis "..." to indicate
      continuation.

      Tabs inside quoted strings are converted to blanks when they are
      written out.  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.  The program will also accept blanks at the
      ends of lines.  These are converted to tabs internally.  These
      features allow one to extend the length of a feature to the right so
      that it will exclude other features from that area.

      When features are generated automatically by the scan program, the Ribl
      matrix is stored in the features file.  This begins with the letter 'r'
      followed by a quoted string (eg "Fis") that relates the matrix to the
      definition.  This is followed by the standard ribl file format defined in
      the ri program.  These data allow the walker to be created, but since it
      is done automatically the user usually need not create this by hand.

      If the feature has an Ribl matrix definition (because, for example it was
      created by scan as described above), then the three values for Ri, Z and
      probability follow the "other" string.  These are usually generated
      automatically by the scan program and not by the user.

      As in the walker program, the walker has a light green or pink
      bar at zero.  The color of the bar is determined for each feature
      from the evaluation values mentioned above and from new boundaries
      defined by the user:
         * Ribound: lowest Ri for producing a green bar
         * Zbound: lowest absolute Z score for producing a green bar
         * Pbound: lowest probability for producing a green bar
      These cannot be defined in the scan program since one would like to scan
      with lenient bounds and then make a more stringent bound at the lister
      level to mark those which passed the second stage.  Thus strong sites are
      shown in green and weaker ones in pink.  This requires a definition of
      the boundaries.  The first character of the line must be 'b'.  The rest
      of the word is ignored.  This is followed by a quoted string that relates
      the boundaries to the definition.  The three bounds are then given.    An
      example for the Fis features is:

         boundaries "Fis" 10.5 2.0 0.20

      where Ribound = 10.5, Zbound = 2.00 and Pbound = 0.2.  This means that
      only sites with Ri> Ribound, Z <= Zbound and probability >= p will get a
      green bar.  (The order of these paramters is the order they
      are computed in.  Ri determines Z, and this determines probability.)

      NO LONGER TRUE:
      Any characters on the line after those expected (the list of locations
      for definitions and the second quoted string for the features and the
      Ri, Z and probability) are
      ignored and may be used as comments.

      COLOR OF CHARACTER FEATURES

      The color of text character features can be changed by adding
      a set of 5 parameters at the end of the '@' line. 
  
      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
         Tparam values:
            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.

      Many feature files may be concatenated together to create complex
      features.  This allows the user to add their own features and to set
      the boundaries as defined above.

      If a program that generates features searches a book with several
      identical pieces, then multiple copies of a feature can be found.
      These duplicates are removed by the program.  (To allow the duplicates
      to be kept, the parameter KeepDuplicates can be set to true.)
      Note that the program cannot identify duplicates if they are on
      the opposite strand!

      New as of 1999 March 11:
      Makelogo has the ability to put cosine waves on the sequence logo.
      This is now possible for lister walkers.  If the ri program is run with
      a non-empty wave file, then the ribl will contain a wave definition.
      This is passed into the scanfeatures file and and used to mark the
      walker.  Thus if one defines one (or more!) waves on the sequence logo,
      these will automatically appear on the corresponding walkers!

      New as of 1999 April 1:
      One can have features with italic characters in them.  For example to
      make the word 'Italy' be in italics, use the string:
         \)\(Italy\)IT\(
      This can be done both inside the Delila instruction name string and
      inside the names of features.  To use it in the search strings, one
      must replace all spaces by tabs, but otherwise the syntax is the same.
      TECHNICAL NOTE (how it works): The first right parenthesis closes any
      previous postscript string.  The word to be italicized is in
      parenthesis.  Then the IT function is called to write it out.  The
      final left parenthesis starts any remaining postscript string.

      WARNING #1:  Other features on the rest of the line may be displaced
      slightly.

      WARNING #2:  You must use tabs instead of spaces if you generate your
      features using the search program.  You can use spaces in delila name
      instructions.

      New as of 1999 April 7:
      One can generate any of the standard PostScript symbols (PostScript
      Language Reference Manual, second ed, 1990, ISBN 0-201-18127-4, section
      E.11, Symbol Character Set, p. 604).  For example, this will produce a
      beta symbol: "\)\(\\142\)SY\(".  Note that two backslashes are needed
      in front of the 142 to ensure that a backslash appears in the
      PostScript.

      New as of 2003 Aug 18:
      If Delila halts, then the scan program halts and an 'h' appears
      in the feature file.  This is now a valid initial character
      for features, and it triggers a warning.

      COLOR RECTANGLES BEHIND WALKERS: petals *********************
      New as of 2004 July 13

      Color rectangles behind walkers - called 'petals' can be
      defined.  This allows one to see each kind of walker with its
      own color.  The form of the line is:

      petal "ribl_name" el c eh es eb fh fs fb th

      ribl-name = the name of the kind of walker to use
      el = edgelinewidth: edge linewidth (integer)
      c  = color kind: how color is defined: r for RGB, h for HSB
      eh = edgeh: edge hue        OR red
      es = edges: edge saturation OR green
      eb = edgeb: edge brightness OR blue
      fh = fillh: fill hue        OR red
      fs = fills: fill saturation OR green
      fb = fillb: fill brightness OR blue
      th = thickness of the petal

      The user defines:

      - the name of the Ribl weight matrix (inside quotes);

      - the edge thickness (el);  If el is 1 or larger, then el is the
      thickness in PostScript points (1/72 inch).  If el is 0 then the
      thickness is 1 pixlel on the display.  If el is negative then no
      edge is given.

      - whether to use
      RGB (red, green, blue) or HSB (hue saturation brightness)
      for the color definitions (values range between 0 and 1);

      - the color of the edge of the rectangle;

      - the color of the interior of the rectangle;

      The thickness is a number between 0 and 1.
      When it is 1.0, the height of each colored rectangle
      is the full height of a character in the font.
      As this number decreases, the rectangle shrinks in the
      vertical direction to the center of the character.

      These parameters apply only to the walker defined.
      The ribl must be defined before the petal definition.

      Color Intensity Control:

      The color values can be controlled automatically.  The Ri value
      of the site is known and the consensus is known.  Dividing Ri by
      the consensus gives a range from 0 to 1.  If the Ri is negative,
      0 is used.  Color values (any of hue, saturation, brightness,
      red, green and blue) are normally in the range 0 to 1, so to
      trigger this mechanism for any color value, use a value less
      than zero.  The color value will then vary with the information
      content of the site.

      When the color value is negative, use a value of -1 to
      get the range 0 to Ri/consensus.

      In general, when the color value is negative, use other values
      to scale up the color range.  That is, if the value is scale < 0,
      then the color range will be 0 to Ri*abs(scale)/consensus.  Any
      values that exceed 1 are set to 1.  This allows one to enhance
      the sensitivity.

      The most simple way to vary the color is to use the hsb model
      and to have the hue determined by the binding site model, the
      brightness fully up and the saturation determined by the
      information content of the site.  Thus a red site with zero
      information content will be white, one with about average
      information content will be pink and the strongest site (the
      consensus) will be full red.  The mkpetals script will
      automatically set this for you if you provide it with a features
      file that contains ribl files (the usual output of scan or
      multiscan).  In PostScript, the first color is always red so the
      output for the first sequence walker in the features file are
      called "rose petals".

      *************************************************************

   colors: colors defining the bases, see makelogo for definition.  Each line
      either begins with a '*' (comment) or a character.  The character is then
      followed by three real numbers (between 0 and 1) that define the amounts
      of red, green and blue.  There is also a conflict between the amino acid
      letters and the DNA sequence bases, but is be resolved by making the
      bases only in lower letters case and the amino acids only in upper case
      letters in the colors definition file.

   marks:  Define the location of marks on the map.  See makelogo.p for
      details of this method.  Note that the horizontal positions are given in
      coordinates of the piece (rather than coordinates relative to the zero
      base of the logo) and that vertical positions are still given in bits,
      with one bit per vertical character size.  The marks are relative to the
      first line of the listing, so mark positions should usually have negative
      y (bit) locations.  These marks are global and appear under all other ink
      put on the page.  They should not be confused with the character marks of
      individual features.  Marks are drawn before the other features in the
      listing and so appear underneath them.  Marks are drawn from the left to
      the right and the first coordinate of a mark defines its order of
      drawing.  The order of the marks must be the order they are to be drawn
      in.  As described in makelogo.p, the user can define their own marks.

      SPECIAL COMMAND: p
      There are many times when one would like to skip ahead to the next
      piece in the book for the next mark.  The 'p' command in the marks file
      (ie, just p at start of line with any characters following) means that
      marks should not be gotten until the start of the next piece.  By
      convention, one does not need to step to the first piece, and one
      should always use the p command to have lister move to the next piece
      when one is done with a given piece.  These rules prevent insanity.

      SPECIAL TRICKS:
      One can redefine Postscript functions in the marks file if one knows
      how lister works.  In particular, if one needs to make a black and
      white figure, then the black down box will be the same shade as the
      base and the base won't be visible.  To allow the normally purple and
      black down box colors to be changed, both are defined as 'downblack'
      and 'downpurple'.  These can be redefined.  For example:  "/downblack
      {0.9 setgray} def" redefines downblack set the shade to gray so that
      the base is not wiped out.

writeln(output);
      SPECIAL COMMAND: o, which controls the marksorder parameter.  The 'o'
      command controls when the marks are written.  For example, it allows
      one to overwrite the DNA sequence with marks.  The "o" command must be
      followed by a character, bNADF.  The default is that marks are written
      BEFORE (b) everything else, so they are under all other graphics.  The
      other values set the time that marks are written:  N (after the
      numbers), D (after DNA), A (after amino acids) or F (after features).
      Note that the coordinate system changes after each of these:  it is
      displaced downwards.

   list:  A carefully numbered listing of the sequences in book, with amino
      acid translations and features marked and with an index to the pieces
      at the end.  The file is pure ASCII.

   map:  like list, but the sequences are in color, according to the colors
      given in the colors file.  The file is in PostScript graphics.  If the
      definition of a site is marked as a walker and if there is a ribl
      information, then the walker will be displayed.

   output: messages to the user

description
   Lister is a general purpose program for the listing of nucleic-acid
   sequences.  Bases are separated by one space.  This gives enough room for
   many features to be shown.

   The listing can have numbering in which every fifth base is carefully marked
   with an asterisk directly above it.  Every tenth base is numbered with the
   number defined by the coordinate system.

   The listing can include translation to amino acids.  The amino acid is set
   directly below the codon.  Dashes mark the frame.

   The listing can include various features defined by a user or automatically
   found by another program.

   The listing can have various user defined marks placed on it.  The locations
   of these marks are given in convenient coordinates (bases and bits).

   Walkers are shown on the color listing (map).  The location to place the
   walkers is determined by the scan program, and read into this program by
   the features file.  To allow concatenation of several scans together, the
   output of the scan program is called scanfeatures.  Walkers consist of a
   set of letters.  The zero base is shown by a rectangle.  The upper line of
   the rectangle is at 2 bits, the lower line is given by the figurebottom
   parameter.  One line of the display is equal to one bit.  The zero height
   is indicated by placement of the letters as described below.  The letters
   of the walker indicate several kinds of data.  Their height is in bits.
   If they point downward, then that represents a negative contribution of
   that base to the individual information.  The orientation of the letters
   indicates the symmetry of the site.  There are three possible symmetries:
   asymmetric, even and odd.  A site with odd symmetry has a base in the
   center.  A site with even symmetry has a phosphate in the center.  The
   symmetry is determined by the ri program, and passed to the scan program
   in the ribl file.  When a site is symmetric, the walker letters are
   vertical.  In this case if their contribution is negative, the letter will
   be rotated 180 degrees so it points downward.  If a site is asymmetric,
   then the walker letters are rotated -90 or +90 degrees (when the Sideways
   parameter is set to 's').  The direction of the site is the direction one
   would read the letters if they were running down a page of text.  If the
   base contributes negatively to the Ri, it is below the zero line of the
   walker.

examples
      If listerp contains:

11.55 version of lister that this parameter file is designed for.
38    basesperline: number of bases per line in the listing
1     aastate: 0=no aa; 1=predict peptides; 2=translate all frames
7     frameallowed: binary; highest bit is highest frame on, etc.
1     codelength: 1 or 3 letters per amino acid
1     seqlines: 0=no sequence; 1=single strand; 2=double strand
c     pageaction: c=computer; l=LaTeX; n=none
60    pagelength:  page length
hoPiNKFC hopinkfc: Header, Organism/chromosome, Piece, Index; #, key, full, coords
NDAF  ndaf: Numbering, DNA, Amino acids, Features
SoF   sof: feature position, S=on SAME line, O=ONE per line, FORWARD/REVERSE.
p     pocld: pagetrigger, piece, organism, chromosome; list, double
C 10  mapcontrol: C=do color map, R= rotate, char height (72 points/inch)
0.3 -0.3 0.5 amount to move image in x and y (cm) and scale factor
-3    lowerbound (bits) lower bound of walker box graphic
-3    figurebottom (bits) lower bound of walker in lines
0     shiftsequence (bases) amount to shift the sequence to the right
sb 20 pageedges: d(default), s(shrinkwrap); pageboundaries (b/n); extraright (integer)
n 0 0 0 0   edgecontrol (p=page), edgeleft, edgeright, edgelow, edgehigh in cm
not keep  KeepDuplicates: k(keep), n(o): keep (or not) duplicate features
sideways  Sideways: s(ideways), n(o): show walker features sideways
0     MinimumLines: minimum lines between sequences
-     artmode: a(rtmode), n(ames), b(black), B(black, controlled), otherwise not.
o  0.3 0.0 outline outlinewidth outlinegray

this means:

11.55 this parameter file will not work with versions less than 11.55
38    the listing will be 38 bases wide
1     with predicted peptides for
7     the top frame.
1     The translated sequence is listed in single letter code.
2     Both DNA strands will be given.
c     The computer's default will be used to page the output.
60    Each page will break at 60 lines.
h     no header will be shown
 o    no organism/chromosome information will be shown
  P   the information about each piece will be shown
   i  no index will be printed at the end.
    N    show piece number
     K   show piece key name
      F  show piece full name
       C show piece coordinate system
N     show Numbering of DNA sequence
 D    show DNA sequence
  a   don't show Amino acid sequence
   F  show Features
S     features are kept at the same level
 o    more than one feature is printed per line
  F   features are in the order given in the features file
p     trigger a new page at every new piece.
C     C = do map
  10  character height 10 points
0.3     move image 0.3 cm x on the page (ie right)
  -0.3    move image -0.3 cm y on the page (ie down)
       0.5   make the image half size
-3    the walker boxes will go down to -3 bits (lines)
-3    the walker will take 3 lines (bits) below zero
0     The sequence will not be shifted.
s     When viewed with ghostview, the image will just fit inside the viewer
 b    The edge of the printable page will be shown in red
   20 the right edge of the image will be extended 20 cm
n     edgecontrol -none (p=page will be controlled)
  0         edgeleft: additional edging in cm
    0       edgeright: additional edging in cm
      0     edgelow: additional edging in cm
        0   edgehigh: additional edging in cm
not   don't keep duplicate features
sideways  rotate the asymmetric walker letters
0     no minimum to lines between sequences
-     artmode turned off, black ASCII characters will be shown
o          outline: letters will have outlines
   0.3     outlinewidth: half of the width in points (1/72 inches)
       0.0 outlinegray: 0 is black, 1 is white for the outline

   More examples for frame control (parameter 3):
      7 (111 in binary) will translate all frames
      4 (100 in binary) will translate only the first frame
      3 (011 in binary) will translate the second and third frames

   More feature examples
      define "GATC" "-" "[0*]" "[*0]" -1.5 -0.5 0 1.5
      @ K01789 281.5 +1 "GATC" ""
      @ K01789 281.5 -1 "GATC" ""

      define "GAnCT" "-" "[0*]" "[*0]" -2 -1 0 2
      @ K01789 282.0 +1 "GAnCT" ""
      @ K01789 282.0 -1 "GAnCT" ""
produce:
    *260      *         *270      *         *280      *         *290
 5' t t a t c c a c a g t a g a t c g c a c g a t c t g t a t a c 3'
 3' a a t a g g t g t c a t c t a g c g t g c t a g a c a t a t g 5'
                                            [-*0--] GATC
                                            [--0*-] GATC
                                            [-*-0---] GAnCT
                                            [---0-*-] GAnCT

   Sometimes one would like to force a particular feature to be somewhere
   else.  One could do this by putting a visible feature there, but then one
   would have characters one does not desire.  A trick is to define a totally
   blank feature:

         * define an invisible feature to displace other features
         define " " " " " " " " 0
         @ J02459 27731 +1 " " " "

   This feature will displace other features, but since it has only blanks, it
   will not show up itself!  By putting this feature before other features in
   the feature list, it will get priority for positioning.

   COLOR OF CHARACTER FEATURES

   define "PEAK" "-" "<0]" "[0>" -1 0 1
   @ NC_000913 152.0 +1 "PEAK" "" R 0 1 0 1

   This makes a green colored '[0>' one character high.

documentation

@article{Schneider.walker,
author = "T. D. Schneider",
title = "Sequence Walkers:
a graphical method to display how binding proteins
interact with {DNA} or {RNA} sequences",
journal = "Nucleic Acids Res.",
volume = "25",
comment = "walker.tex, November 1, issue 21",
note = "\htmladdnormallink
{https://alum.mit.edu/www/toms/paper/walker/}
{https://alum.mit.edu/www/toms/paper/walker/},
erratum: NAR 26(4): 1135, 1998",
pages = "4408-4415",
year = "1997"}

@article{Shultzaberger.Schneider2001,
author = "R. K. Shultzaberger
 and R. E. Bucheimer
 and K. E. Rudd
 and T. D. Schneider",
title = "{Anatomy of \emph{Escherichia coli}
Ribosome Binding Sites}",
journal = "J. Mol. Biol.",
volume = "313",
pages = "215-228",
comment = "Shultzaberger.Schneider.flexrbs",
note = "\htmladdnormallink
{https://alum.mit.edu/www/toms/paper/flexrbs/}
{https://alum.mit.edu/www/toms/paper/flexrbs/}",
year = "2001"}

see also

   {Below is an example lister map of the famous Lac promoter
   region.  The strong CRP site is shown along with the lac
   promoter and the lacZ ribosome binding site. See:}
   https://alum.mit.edu/www/toms/paper/walker/
   {to understand sequence walkers and}
   https://alum.mit.edu/www/toms/paper/flexrbs/
   {for the method of making multi-part sequence walkers.}

   https://alum.mit.edu/www/toms/icons/lister-lac-map.jpg

   {A beautiful example is the cluster of Fis sites (in pink and
   red shades) that control the Fis gene itself:}
   https://alum.mit.edu/www/toms/ftp/fispromoter.pdf
   {This is described in detail at:}
   https://alum.mit.edu/www/toms/fispromoter.html

   width=100%
   https://alum.mit.edu/www/toms/ftp/fispromoterArt.jpg

   {Example parameter file:} listerp
   {Example features:} lister.features
   {Example Delila instruction:} lister.inst
   {Example petalfeatures file:} petalfeatures
   {These were used to generate the map given above.}

   {Example boundaries file:} boundaries

   {Definition and examples of lister maps:}
   https://alum.mit.edu/www/toms/glossary.html#lister_map

   {Definition of lister features:}
   https://alum.mit.edu/www/toms/glossary.html#lister_feature

   {Definition of lister marks:}
   https://alum.mit.edu/www/toms/glossary.html#lister_mark

   {There are also examples in the Delila Tutorial:}
   https://alum.mit.edu/www/toms/delilainstructions.html

   {Related Programs, in approximate order of use:}
   delila.p, alist.p, split.p, dbmutate.p {deprecated},
   scan.p, makewalker.p, ri.p,
   live.p, exon.p,

   {There are two versions of lister:}
   lister.p  {creates sequence walkers and is available by CDA, MTA or license:}
              https://alum.mit.edu/www/toms/contacts.html
   listerx.p {cannot create walkers and is available at this web site.}
             {No longer generated.}

   {For merging multiple marks files:} mergemarks.p

   {Script:} mkbookfeatures

   {Script to automatically create petals (colored rectangles)
   behindcolor the sequence walkers:} mkpetals

   {Script to put a time stamp on the map:} listertimestamp

   {Top 10 things likely to be overheard if you had a Klingon Programmer:}
   http://rucus.ru.ac.za/~urban/docs/humour/Klingon%20Programmers.txt

author
   Thomas D. Schneider

bugs

2004 Dec 5: the following line caused a crash of the
GPC compiler:
   with f^, f^.definition^ do begin {causes GPC crash}
The next line should solve it:
   with f^ do with f^.definition^ do begin

   It would be possible to modify lister so as to report the amino acid
   sequence in the features, but this raises some unresolved issues.  The
   position in the feature is a specific DNA base, so one could report the
   amino acid in the reading frame that starts with that base.  But then the
   very next base will be in a different reading frame.  Perhaps the solution
   is to use the reading frame of the first base marked by the feature?

   The parameter shiftsequence applies to every sequence, there is no
   individual control.

   "UPSIDE DOWN WALKERS"

   Certain combinations of Delila instructions and searches can produce
   incorrect walker listings.  For example, if a binding site is even (ie
   there is no central base) then to get the binding sites with Delila one
   would say:

   organism ecoli; chromosome ecoli; piece ecotrp;
   get from 105 -20 to 105 +20;
   get from 106 +20 to 106 -20;

   (These are instructions to get the trpR sites from the siteli database.)

   If these two same pieces are then scanned, scan will locate one
   site on each of the pieces.  There will, therefore, be two sites
   listed in the data, scaninst and scanfeatures files:

@ ecotrp 105.0 +1 "TrpR" "@ 105|Ri=22.4|Z= 1.4210|p=0.078"    22.430327     1.421045     0.077652
@ ecotrp 106.0 +1 "TrpR" "@ 106|Ri=22.4|Z= 1.4210|p=0.078"    22.430327     1.421045

   Lister will read the scanfeatures and apply them to EVERY piece in the
   book.  Thus it will apply both features to the first piece and both
   features to the second piece.  However, the results on the second piece
   will be incorrect because it is the complementary sequence.
   The walkers generally show up as highly negative.

   A solution to this complex problem is not known.  A practical solution is
   to avoid scaning a sequences in both directions.  That is, for the scan
   only use one Delila instruction.

   Should the walker really define the line to be it's own thickness?  This
   prevents one from putting character type features at any line except the
   walker zero line.

   No, it should not.  Figure out how to get around this.

   2001 Jan 4.  PDF Font Problem.  Before version 9.76 there was a problem
   with conversion from PostScript to pdf by the gs (ghostscript) program.
   Spaces were being compressed so that ascii features were shifted to the
   left.  This was solved by introducing a routine that puts multiple blanks
   out (MB).
   2001 Jan 5.  However this then revealed a much worse problem which is that
   the supposedly constant spacing courier font is not constant spacing for
   parenthesis and dashes!  This cannot be solved in lister directly.  The
   ultimate solution may be to rebuild lister so that every character is
   placed onto the display at a particular coordinate, thereby getting around
   the font failure AND allowing any kind of font to be used.
   Because the symbols '(-)' are used for structures, special code was
   created to solve this 'font compression' problem.

technical notes
   The size of the page in PostScript is determined with 4 constants llx,
   lly, urx and ury.  These must be set correctly for each printer.  These
   can be easily obtained by printing the file:

   https://alum.mit.edu/www/toms/ftp/printerarea.ps

   In this program these parameters are set as 4 constants defaultllx,
   defaultlly, defaulturx and defaultury.  The parameters for pageedges
   define whether to use the defaults or to compute the size to show.

   The prgmod program defines the Ribl reading routines, in module scan.type
   and getriblmatrix.

   The featureinlist routine attempts to detect duplicate features.  This can
   happen when one obtains both the sequence and its complement for a site
   and then one scans that book with the resulting model.  How it is handled
   depends on the symmetry.  Odd and asymmetric cases are ok, but the even
   case is difficult.  It is detected by the zero bases being one position
   apart with opposite orientations, but this will fail if the sites happen
   to fall at a coordinate boundary.  Though rare, at least the only result
   would be an extra walker.

   2000 Jun 28: 9.60: user definitions go into preamble!
   The user may define in the marks file their own postscript code with "u",
   and call it with "U".  In the previous versions of the program the marks
   were written 'on the fly', so that the file was read only once.  This was
   efficient, but caused a subtle bug.  The color wave produced by the live
   program would cause a problem.  In ghostview, if one paged forward or
   backwards quickly and the definition of the wave would be lost and
   ghostview would freeze.  This happend because the marks were put after the
   postscript preamble, so they were not available for every page.  The
   solution was very simple (see usermarkstopreamble): put the user
   definitions into the preamble.  Then every page gets the defintions from
   the preamble and ghostview can page very quickly.  This also allows live
   waves over multiple pages to be sent to our finicky (but correct) color
   printer.  Note that the user definitions are DUPLICATED in the parts after
   the preamble.  This means that the user can change definitions of graphics
   throughout the map, which might be quite useful!

   2006 Oct 20: /FontBBox is an array according to the PostScript
   Language Reference Manual Second Edition (Red book):

       /FontBBox: index on page 754
         page 266-267: CLEARLY says it is an array!
         font metrics and page 273

   Ghostview does give an array, and all is perfect.  However, the
   COLOR 148 printer HP5550PS printer only returns three values ON THE
   STACK instead of 4 values.  I could not figure out what the three
   values are.  So in the letterrectangle routine (which is
   responsible for making the color bar between multipart sequence
   walkers) I used the ghostview values instead!  This works but
   obviously it may not work properly on all printers.
   Bottom line:  The HP printer appears to give an incorrect
   result for /FontBBox.

   google:
   HP printer FontBBox
   gives
   http://www.ghostscript.com/doc/current/History2.htm
   History of Ghostscript versions 2.n

   "- buildfont required the presence of a valid, 4-element FontBBox.
   (The Red Books say it's required, but Adobe interpreters don't
   require it; some DEC software generates a 3-element FontBBox.)"

   So it's true that there are 3-element FontBBoxes!

   http://welcome.hp.com/country/us/en/contact/web_feedback.html

   We have a Hewlett Packard LaserJet 5550 Printer.  I am writing
   postscript code that uses FontBBox.  Although the PostScript
   Language Reference Manual Second Edition (Red book) clearly states
   on page 266-267 that this should return an array, your printer
   returns three integers.  That is a bug in your printer as far as I
   can tell.  I could not figure out what the values are.  So:  (1)
   Please send this message to engineers who can deal with the bug in
   your printer.  (2) Please have them tell me what the three values
   are.  I need the standard llx, lly, urx and ury values of the
   characters.  How do I obtain these?  Thank you.

  Dr. Thomas D. Schneider

From: toms@alum.mit.edu
Sent: 2006-10-20 05:33:10Z (GMT)
Subject: HP U.S. Feedback: http://welcome.hp.com/country/us/en/prodserv.html

2006 Oct 26: 11.71: bug: acrobat 7.0 display on the sun is overwriting
the background under the walkers as one advances pages!  The
background (normally white) becomes a colorful total mess.  Change
routine startpage to have gsave as first thing.  The display is still
ok, but the bug is still there.  AH! page 13 was 'blank'.  But when I
delete that page (by hand) it messes up anyway starting on page 14.
Acrobat display on the Mac is fine, this is a Sun-specific problem.
Deleting the first 9 pages in the ps problem gone from 10 until page
22 - ie actual page 13 again!  Deleting to page 19, so it starts on
numbered page 20 - now the bug appears on page actual page 13 again!
So it's not the actual code, it's something about the length of the
material.  Maybe some limit of Acrobat is being exceeded.  Cannot
solve.

2012 Apr 18 for human sequences the numbers can be quite large.  They
can bump into the astrisks: *138623230*.  This is now ambiguous, so I
changed the '*' for 5 steps to be ',' giving: '*138623230,'.

2016 Aug 19: I switched functions to avoid using external coordinates
because a two-part walker over a circular coordinate bound cannot be
read in properly.  Instead, each group is marked by 'group' and each
feature has a coordinate distance from the total zero.
gggg

****************************************************************************

   Google:
   "Top 10 things likely to be overheard if you had a Klingon Programmer"
   http://rucus.ru.ac.za/~urban/docs/humour/Klingon%20Programmers.txt

Top 10 things likely to be overheard if you had a Klingon Programmer:

10) Specifications are for the weak and timid!
 9) You question the worthiness of my code?  I should kill you where you stand!
 8) Indentation?! - I will show you how to indent when I indent your skull!
 7) What is this talk of 'release'?  Klingons do not make software 'releases'.
    Our software 'escapes' leaving a bloody trail of designers and quality
    assurance people in its wake.
 6) Klingon function calls do not have 'parameters' - they have 'arguments'
     - and they ALWAYS WIN THEM.
 5) Debugging?  Klingons do not debug.  Our software does not coddle the weak.
 4) A TRUE Klingon Warrior does not comment his code!
 3) Klingon software does NOT have BUGS.  It has FEATURES, and those features
    are too sophisticated for a Romulan pig like you to understand.
 2) You cannot truly appreciate Dilbert unless you've read it in the
    original Klingon.
 1) Our users will know fear and cower before our software!  Ship it!  Ship
    it and let them flee like the dogs they are!

*)
(* end module describe.lister *)

   globaldebug = false; (* global debugs in prgmods *)

(*
   Backslash functions are defined in two procedures called dobackslash,
   one for names from books and the other for names from features.
*)

(*
1999 Mar 11 The following problem was solved by introducing the
p command in the marks file:
   The Multiple Marks Problem:  Mark locations are given only by coordinates
   in the marks file.  Lister reads and processes all marks at a single
   location at once.  Thus two marks at 7 will show up.  However sometimes
   one will have several pieces (even with the same piece name) and want to
   mark each piece at the same coordinates with one mark per piece.  With the
   current algorithm, Lister would put ALL of the marks on the first piece
   only.  If the algorithm is altered to only put one mark at a location,
   then one could never put two marks at the same place, so that is not
   acceptable.  The solution is to put invisible marks on the listing to
   reset the marks file.  Thus one would have a mark at 7, and then an
   invisible mark at 1 (to force the program to wait for the next piece)
   followed by the next mark at 7.  Alternatively, one can put two visible
   marks per piece:  1, 7, 1, 7 so that the marks routine will reset
   properly.
*)

(* for details on lister parameters see the settable variables. *)

(* more constants: *)

   debug = false; (* debugging the code *)
   intensedebug  = false; (* intensely 8-} debugging the code *)

   writecharwidthmessage = false; (* write a charwidth message.
   Unfortunately this now (2006 Apr 17, Ghostscript 8.14) shows up as
   an information box in ghostscript, which gets in the way.  So
   just let the program do its thing and not get in the way. *)

(* begin module string.const *)
      maxstring = 2000; (* the maximum string *)
(* end module string.const version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module lister.const *)
   (* defaults for settable variables *)
   defbasesperline = 30;
   defaastate = 1;
   defframeallowed = 7;
   defcodelength = 3;
   defseqlines = 1;
   defpageaction = 'c'; (* page action *)
   defpagelength = 55; (* number of lines on a page *)
   defhopi = 'HOPI'; (* parts of display to print *)
   defnkfc = 'NKFC'; (* parts of piece information to print *)
   defndaf = 'NDAF'; (* default ndaf data controls *)
   defsof = 'SOF'; (* default sof feature controls *)
   prime = ''''; (* single quote mark *)

   shiftright = 3; (* number of characters to shift the features right
                      on the page *)
   tabcharacter = 9; (* the ordinal of the tab character *)
   maxdatacontrol = 4; (* maximum number of data controls *)
   maxsof = 3; (* maximum number of sof feature controls *)

   (* default bounding box definitions.  See the technical notes for how to
      set this for a different printer. *)


   (* The following bounding box is for the Canon Color Laser Copier 1150. *)
   defaultllx =   7.10999; (* default for llx, lower left x *)
   defaultlly =   7.01995; (* default for lly, lower left y *)
   defaulturx = 588.15;    (* default for urx, upper right x *)
   defaultury = 784.98;    (* default for ury, upper right y *)

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

(* PostScript constants *)
   pwid = 8; (* width in character places to print PostScript numbers *)
   pdec = 5; (* decimal places to print PostScript numbers *)
   pdecolor = 4; (* decimal places for color descriptions (5 WILL CAUSE
                    NeWS 1.1 TO BOMB) *)

   defcharacterratio = 0.6; (* default for the ratio of the rightward
      horizontal motion when a character is drawn to the font height.  This is
      determined by the map file, but this program needs to know it also to
      do the mark computations. *)
   tolerateratio = 10000; (* the tolerance in decimal place to accept
      in comparing the value of defcharacterratio with that determined
      by the PostScript interpreter *)

   linemax = 1000; (* longest output line possible *)

    tenspacemark = '*'; (* the symbol to put every 10 bases 2012 Oct 25 *)
   fivespacemark = '.'; (* the symbol to put every 5 bases that is not
                          tenspacemark. 2012 Oct 25 *)

(* end module lister.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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

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

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

(* end module book.const.for.lister *)

(* begin module datetime.const *)

   datetimearraylength = 19; (* length of dataarray for dates,
       It is just long enough to include the 4 digit year - solving the
       year 2000 problem:
1980/06/09 18:49:11
123456789 123456789
         1         2
*)

(* end module datetime.const version = 7.70; {of delmod.p 2005 Sep 15} *)

type

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

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

      (* types defined in book definition *)

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

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

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

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

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

(* begin module base.type *)
   (* define the four nucleotide bases *)
   base = (a,c,g,t);
(* end module base.type version = 7.70; {of delmod.p 2005 Sep 15} *)

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


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

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

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


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

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

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

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

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

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

(* end module book.type version = 7.70; {of delmod.p 2005 Sep 15} *)

(* begin module amino.type *)
      aminoacid = packed array[1..3] of char;
(* end module amino.type version = 7.70; {of delmod.p 2005 Sep 15} *)

(* begin module datetime.type *)
   (* array for dates *)
   datetimearray = packed array[1..datetimearraylength] of char;
(* end module datetime.type version = 7.70; {of delmod.p 2005 Sep 15} *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

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

(* begin module readdefinitionsandfeaturesVariables *)
readdefinitionsandfeaturesVariables = record
(* ALL LOCAL VARIABLES of procedure readdefinitionsandfeatures
ARE CARRIED IN readdefinitionsandfeaturesVariables.
*)
   verbose: boolean; (* give verbose output *)
   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 *)
   (* 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 *)
end;
(* end module readdefinitionsandfeaturesVariables *)

(* end module definition.feature.type version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module more.lister.types *)
   (* More types not needed by other programs *)
   (* the datacontrol record defines the kind and order of data lines
      to be output *)
   typedatacontrol = packed array[1..maxdatacontrol] of char;

   (* a list of piece numbers to trigger paging *)
   ptrigptr = ^ptrigrecord;
   ptrigrecord = record
      trigger: integer;
      next: ptrigptr;
   end;

   array4 = packed array[1..4] of char; (* a 4 character array *)

   (* a single feature and a state associated with it *)
   featurememoryptr = ^featurememory; (* linked list of memories *)
   featurememory = record
      feature: featuretypeptr; (* the feature we are recalling *)
      state: real; (* the state of the memory:
{vvv}
         0 means that there is no memory
         1 means that one feature needs to be written still
         2 means that two features need to be written still
        >2 means that more than 2 features need to be written still
           OR?? we are still writing a walker so the colorletter
           should be suppressed?  Maybe we need more states
           for writing walker regions?
        2018 Mar 15: the above may be passe as the 
        featurememoryptr method takes over.
        However, for walkermemory maybe it's ok?
         *)
      next: featurememoryptr; (* next feature *)
   end;
   (* a feature memory *)
   featurememoryarray = array[1..linemax] of featurememory;

   linetype = array[1..linemax] of char; (* character lines *)

(* end module more.lister.types *)

var
(* begin module feature.globals *)
(* globals needed by lister.p: *)
   groupnumber: integer; (* counted group number *)
{zzzrrr}
   localRDAFvariables: readdefinitionsandfeaturesVariables;
   (* These variables are held for the readdefinitionsandfeatures
      procedure so that it can be called repeatedly and not forget
      the states of the variables.  This is generally not to be
      touched by the outside code - they are "local" to
      readdefinitionsandfeatures. *)
(* end module feature.globals version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module lister.var *)
   parameterversion: real; (* parameter version number *)
   (* this is a global to allow upgrading between versions *)

   (* files manipulated by lister: *)
   book, listerp, features, colors, list, map, marks: text;
   internalindex: text; (* temporary place to keep the index while the
                   list is being made *)

   firstpiece: boolean; (* are we looking at the first piece?
      in all cases except the first piece, we want to consider paging *)

   ch: char; (* book reading character *)
   theorg: orgkey; (* the current organism *)
   thechr: chrkey; (* the current chromosome *)
   orgchange, chrchange, piechange: boolean; (* that any changed *)
   orgopen, chropen, pieopen: boolean; (* used by getocp *)
   pie: pieceptr;
   width: integer; (* the width in characters of a piece name *)

   pagenumber: integer; (* the page of the listing *)
   linenumber: integer; (* the line on the page *)
   actualmax: integer; (* actual length of the line used *)

   (* listerp: user settable variables *)
   aastate: integer; (* how to list amino acids:
                        0 = none
                        1 = on when past atg, gtg or ttg starts,
                            show all nonsense codons.
                        2 = all frames on
                     *)

   artmode: char; (* 'a': the map contains no black letters,
                     'b': no black letters and black background,
                     'B': no black letters and black background, controllable,
                     'n': names given; otherwise all black letters
                     will be shown. *)
   antiartmode: boolean; (* true only when writing names *)

   basesperline: integer; (* number of bases per line in list *)
   codelength: integer; (* number of letters for amino acid printing *)
   frameallowed: integer; (* what frames are allowed to be printed:
                          a binary number representing the three frames *)
   frame0allowed, frame1allowed, frame2allowed: boolean;
                       (* the boolean equivalents of frameallowed *)
   framecalc: 0..7; (* used to calculate the framenallowed variables
                       from frameallowed *)
   aalines: integer; (* the number of amino acid lines to be printed *)
   seqlines: integer; (* how many lines of sequence to write *)
   giveframes: boolean; (* show all amino acid frames without emphasis *)

   (* bounding box definitions: *)
   llx: real; (* lower left x *)
   lly: real; (* lower left y *)
   urx: real; (* upper left x *)
   ury: real; (* upper left y *)

   KeepDuplicates: boolean; (* If set to true, duplicate features
      are kept, if false, they are eliminated.
      argument to readdefinitionsandfeatures *)
   comments: stringptr; (* argument to readdefinitionsandfeatures *)
   windowsize: integer; (* argument to readdefinitionsandfeatures *)

   textline: linetype; (* line of text being printed.  This is
      mainly used to pass the vertical bar information to nextline *)

   MinimumLines: integer; (* The minimum number of lines between sequences *)

{ooo}
   outline: char; (* 'o': outline sequence walker letters *)
   outlinewidth: real; (* outline stroke width *)
   outlinegray: real;  (* outline gray scale *)

   packet: integer; (* the number of lines printed along with
                       one line of sequence: it must not be broken
                       at the page boundry *)
   pageaction: char; (* what to do at page breaks *)
   pagelength: integer; (* length of pages *)

   hopi: array4; (* define parts to display *)
   printheader: boolean; (* whether to print the header information *)
   printorgchr: boolean; (* whether to print the orgchr information *)
   printpiece : boolean; (* whether to print the piece  information *)
   printindex : boolean; (* whether to print the index  information *)
   nkfc: array4; (* define parts of piece display *)

   ndaf: typedatacontrol; (* control the order of data output *)

   Sideways: boolean; (* If set to true, asymmetric walkers are
      shown with sideways letters *)

   sof: packed array[1..maxsof] of char; (* define sof feature controls *)

   totallineswritten: integer; (* track total lines written to
      be able to do at least MinimumLines *)

   featurelist: featuretypeptr; (* the list of all features *)
   definitionlist: definitiontypeptr; (* the list of all definitions *)

   featuresOnSameLine: boolean; (* true means that features are kept at the
      same level of the features printed *)
   featuresOnePerLine: boolean; (* true means that the features only come
      one per line *)
   featuresForward: boolean; (* true means that the features are written
      in the order of the features file, false means they are written
      the other way. *)

   pagetrigger: char; (* triggers new pages *)
   ptrigs: ptrigptr; (* piece numbers for triggering pages *)
   ptrig:  ptrigptr; (* pointer for making the pagetrigger list *)
   colorlistcontrol: char; (* control map production *)
   mapcontrol: boolean; (* true if colorlistcontrol = 'C' or 'R' *)
   deltaXcm: real; (* amount to move the entire page in X *)
   deltaYcm: real; (* amount to move the entire page in Y *)
   scaleimage: real; (* amount to scale the entire page from upper left
                        corner *)
   fontsize: integer; (* font size in points (72 points/inch) *)
   showingbox: boolean; (* whether we are showing the dashed box
      around the walker or not *)
   upperbound: integer; (* upper bound of walker display, in bits *)
   lowerbound: integer; (* lower bound of walker display, in bits *)
   figurebottom: integer; (* lower bound of walker in lines (= bits) *)
   shiftsequence: integer; (* amount to shift sequence to the right *)
   pageedges: char; (* d = default page bounds, s = shrinkwrap *)
   pageboundaries: char; (* b = show page boundaries *)
   extraright: integer; (* number of extra characters to allow for
       on the right side of the map *)
   firstone: boolean; (* true if we are working with the first line *)

   edgecontrol: char; (* if 'p' then use page instead of edges *)
   edgeleft, edgeright, edgelow, edgehigh: real; (* edges around the clist *)

   (* things for marks *)
   cmperpoint: real; (* cm/points, converts to cm from points *)
   markbase1: real; (* location in bases of the marksymbol or its start *)
   markbase2: real; (* location in bases of the marksymbol end *)
   markbits1: real; (* location in bits of the marksymbol or its start *)
   markbits2: real; (* location in bits of the marksymbol end *)
   markscale: real; (* factor by which to change the size of the marksymbol *)
   marksymbol: char; (* a symbol to mark on the logo *)
   marktype: char; (* how to mark a symbol on the logo: dash, fill, stroke *)
   nextmark: integer; (* the position to place the next mark *)
   waitfornextpiece: boolean; (* wait for next piece of DNA before doing the
                                 next mark *)

   charwidth: real; (* width of characters across in cm *)
   charwidth2m: real; (* twice charwidth *)
   cmperbit: real; (* cm per bit *)

   theline: integer; (* current line in book *)

   marksorder: char; (* When to write marks out.
      the default is 'b'= before everything; otherwise
      NDAF for numbering, DNA, amino, features *)

   (* Define a horizontal memory of bar features for writing
      colors along horizontal bars according to features
      pointed to. *)
   horizontalmemory: featurememoryarray;

   (* define horizontal bar paramters: *)
   (* controls for horizontal bars, produced by letterrectangle *)
   dohorizontal: boolean; (* horizontal mode turned on or off *) {HHH}
   horizontalbarwidth: real; (* 1 is normal character width. 0.5 is half wide *)
   horizontalbarheight: real; (* 1 is normal char. height. 0.5 is half height *)
{This is controlled by the feature itself!}
   horizontalbarcharacter: char; (* the character for horizontal bars *)

   (* Define a vertical memory of previous walkers and Gap or total
      features that have been written.  This memory allows
      vertical connections to be made between these objects. *)
   dovertical: boolean; (* vertical mode turned on or off *) {VVV}
   verticalmemory: featurememoryarray; (* memory of vertical lines *)
   vmmax: integer; (* the highest used horizontal position of verticalmemory
      This allows the line to be written far enough to the right
      to include the vertical memory on the right side. *)
   dummy: integer; (* a variable to keep nextline happy in cases
     where verticalmemory is not relevant (eg writing sequence
     coordinate numbers).  Otherwise one uses blankcount. *)

   (* controls for vertical bars, produced by letterrectangle *)
   verticalbarwidth: real; (* 1 is normal character width. 0.5 is half wide *)
   verticalbarheight: real; (* 1 is normal character height. 0.5 is half height *)
   verticalbarcharacter: char; (* the character for vertical bars *)

   (* The walkermemory keeps track of where there are sequence walkers
      over a series of lines.  Sequence walkers must not be
      overwritten by the vertical lines associated with
      verticalmemory, and this memory must therefore be checked before
      a verticalmemory line is written.  The values start at
      2-lowerbound+1 and decay to zero.  This accounts for varying
      heights of walkers (+2 to lowerbound) and the current line (+1).
      Typically lowerbound = -3 (bits) so the initial value would be
      4. *)
   walkermemory: featurememoryarray;
   wamax: integer; (* the highest used position of walkermemory *)
{uuu}
{vvv}

(* end module lister.var *)

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

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

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

(* ************************************************************************ *)
(* end module book.var version = 7.70; {of delmod.p 2005 Sep 15} *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module copyaline *)
procedure copyaline(var fin, fout: text);
(* copy a line from file fin to file fout *)
begin (* copyaline *)
      while not eoln(fin) do begin
         fout^ := fin^;
         put(fout);
         get(fin)
      end;
      readln(fin);
      writeln(fout);
end; (* copyaline *)
(* end module copyaline version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module package.datetime *)
(* ************************************************************************ *)
(* begin module getdatetime *)
procedure getdatetime(var adatetime: datetimearray);
(* get the date and time into a single array from the system clock.
   adatetime contains the date:
       1980/06/09 18:49:11
         ye mo da ho mi se
(year, month, day, hour, minute, second).
As of 2000 February 18, the Sun Pascal compiler requires a formatting
statement.  This statement allows the date to be generated in this
standard Delila format in a single call.  Information about the
formatting statement is available on the manual page for date in Unix.
If a computer does not have this method, see the 'oldgetdatetime' routine
in delmod.p (https://alum.mit.edu/www/toms/delila/delmod.html)
for some conversion code.

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

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

7.10.8 Date And Time Routines

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

DateLength and TimeLength are implementation dependent constants.

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

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

*)
var
    t: TimeStamp;

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

begin

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

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

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

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

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

(* begin module timeseed *)
(* Read the computer date and time.  Reverse the order of the digits and put
a decimal point in front.  This gives a fraction between zero and one that
varies quite quickly, and is always unique (if the computer has sufficient
accuracy).  It is to be used as a seed to a random number generator.  This
has the nice property that the seed changes every second and does not repeat
for thousands of years!  *)
procedure addtoseed(var seed, power: real; c: char);
(* add the digit represented by c to the seed at the power position *)
var
      n: integer; (* the character represented by c *)
begin (* addtoseed *)
      power := power/10;
{
writeln(output,'addtoseed, c = ',c);
writeln(output,'addtoseed, ord(c) = ',ord(c));
}
   n := ord(c) - ord('0');
   if (n < 0) or (n > 9) then begin
      writeln(output,'timeseed: error in datetime');
      writeln(output,'it contains "',c,'" which is not a number.');
      writeln(output,'The getdatetime routine must be fixed.');
      halt;
   end;
   seed := seed + power*n
end; (* addtoseed *)

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

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

procedure timeseed(var seed: real);
(* read the computer date and time.  reverse the order of the digits
and put a decimal point in front.  this gives a fraction between
zero and one that varies quite quickly, and is always unique (if the
computer has sufficient accuracy).  it is to be used as a seed to
a random number generator. *)
var
   adatetime: datetimearray; (* a date and time *)
begin (* timeseed *)
   getdatetime(adatetime);
{
writeln(output,'timeseed: adatetime: ',adatetime);
}
   makeseed(adatetime, seed);
end; (* timeseed *)
(* end module timeseed version = 1.17; (@ of timegpc.p 2002 Oct 9 *)

(* begin module limitdate *)
procedure limitdate(a,b,c,d: char; limitdatetime: datetimearray);
(* test whether the current time is before the limit.
If it is later, halt the program *)
var
   adatetime: datetimearray; (* a date and time *)
   Dday: real; (* the critical day *)
   now: real;  (* this very moment *)
begin
   getdatetime(adatetime);
{
writeln(output,'adatetime:',adatetime);
writeln(output,'adatetime[1]: ', adatetime[1]);
writeln(output,'adatetime[2]: ', adatetime[2]);
writeln(output,'adatetime[3]: ', adatetime[3]);
writeln(output,'adatetime[4]: ', adatetime[4]);
writeln(output,'adatetime[5]: ', adatetime[5]);
}

   orderseed(adatetime, now);

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

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

   orderseed(limitdatetime, Dday);

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

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

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

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

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

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

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

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

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

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

procedure showfreedna;
(* show the freedna list *)
var
   counter: integer; (* count of freedna list *)
   l: dnaptr; (* pointer into freedna list *)
begin
   l := freedna;
   counter := 0;
   while l <> nil do begin
      counter := succ(counter);
      write(output,counter:1);
      write(output, ', length = ',l^.length:1);
{
This is illegal according to gpc because one cannot
write a pointer to a text file.  It can be unearthed
for debugging.
      write(output, ', pointer id: ',l:1);
}
      writeln(output);
      l := l^.next
   end;
end;

procedure cleardna(var l: dnaptr);
(* clear the dna strutures to the free list *)
var   lptr: dnaptr;
begin
      if l<>nil then begin
         lptr:=l;
         l:=l^.next;
         lptr^.next:=freedna;
         freedna:=lptr
      end
end;

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

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

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

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

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

function chomplement(b: char): char;
(* create the character complement of base b.  I must be getting hungry! *)
begin
  chomplement := basetochar(complement(chartobase(b)));
end;

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

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

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

(* end module book.basis version = 7.70; {of delmod.p 2005 Sep 15} *)

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

(* begin module book.skipstar *)
procedure skipstar(var thefile: text);
(* skip start of line (or star = '*'). *)
begin (* skipstar *)
   if eof(thefile) then begin
      writeln(output,' procedure skipstar: end of book found');
      halt
   end
   else begin
      if thefile^ <> '*' then begin
         writeln(output,' procedure skipstar: bad book');
         writeln(output,' "*" expected as first character on the line, but "',
                        thefile^,'" was found');
         halt
      end;
      get(thefile); (* skip the star *)
      if thefile^ <> ' ' then begin
         writeln(output,' procedure skipstar: bad book');
         writeln(output,' "* " expected on a line but "*',
                        thefile^,'" was found');
         halt
      end;
      get(thefile) (* skip the blank *)
   end
end; (* skipstar *)
(* end module book.skipstar version = 7.70; {of delmod.p 2005 Sep 15} *)

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

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

(* begin module book.brname *)
procedure brname(var thefile: text; var theline: integer; var nam: name);
(* read a name from the file *)
var   i: integer; (* an index to the name *)
      c: char; (* a character read *)
begin (* brname *)
      skipstar(thefile);
      with nam do begin
         length:=0;
         repeat
            length:=succ(length);
            read(thefile,c);
            letters[length] := c
         until (eoln(thefile)) or
               (length>=namelength) or
               (letters[length]=' ');
         if letters[length]=' ' then length:=length-1;
         if length<namelength
            then for i:=length+1 to namelength do letters[i]:=' '
      end;
      readln(thefile);
      theline := succ(theline)
end; (* brname *)
(* end module book.brname version = 7.70; {of delmod.p 2005 Sep 15} *)

(* begin module book.brline *)
procedure brline(var thefile: text; var theline: integer; var l: lineptr);
(* read a line from the file *)
var
      i: integer;
      acharacter: char;
begin
      skipstar(thefile);
      i:=0;
      (* protection added 2005 Sep 15 *)
      while (not eoln(thefile)) and (i < linelength)  do begin
         i:=succ(i);
         read(thefile,acharacter);
         l^.letters[i]:=acharacter
      end;
      (* protection added 2005 Sep 15 *)
      if not eoln(thefile) then begin
         writeln(output,'***********************************************');
         writeln(output,'* WARNING: brline: book line length exceeded');
         writeln(output,'* linelength > ',linelength:1,' characters');
         writeln(output,'* Only ',linelength:1,' characters read from book');
         writeln(output,'***********************************************');
      end;
      l^.length:=i;
      l^.next:=nil;
      readln(thefile);
      theline := succ(theline)
end;
(* end module book.brline version = 7.70; {of delmod.p 2005 Sep 15} *)

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

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

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

(* begin module book.brnote *)
procedure brnote(var thefile: text; var theline: integer; var note: lineptr);
(* read note key *)
var
      newnote: lineptr; (* the new note *)
      previousnote: lineptr; (* the last line of the notes *)
begin (* brnote *)
      note:=nil;
      if thefile^ = 'n' then begin (* enter note *)
         readln(thefile);
         theline := succ(theline);
         if thefile^ <> 'n' then begin (* abort null note (n/n) *)
            getline(note);
            newnote:=note;
            while thefile^ <> 'n' do begin (* wait until end of note *)
               brline(thefile,theline,newnote);
               previousnote:=newnote;
               (* get next note *)
               getline(newnote^.next);
               newnote:=newnote^.next;
            end;
            (* last note was not used, so: *)
            clearline(newnote);
            previousnote^.next:=nil;
            readln(thefile);
            theline := succ(theline);
         end
         else begin
            readln(thefile);
            theline := succ(theline);
         end;
      end
end; (* brnote *)
(* end module book.brnote version = 7.70; {of delmod.p 2005 Sep 15} *)

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

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

         (* read note key *)
         if readnumber then brnotenumber(thefile,theline,note)
                       else brnote(thefile,theline,note)
      end
end;
(* end module book.brheader version = 7.70; {of delmod.p 2005 Sep 15} *)

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

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

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

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

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

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

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

      readnumber:=true; (* usually we read in numbers for items *)
      number:=0; (* arbitrary value *)
      numbered:=false; (* the piece has no number (none yet read in) *)
      skipunnum:=false;
   theline := 1;
end; (* brinit *)
(* end module book.brinit version = 7.70; {of delmod.p 2005 Sep 15} *)

(* ************************************************************************ *)
(* end module package.brpiece version = 7.70; {of delmod.p 2005 Sep 15} *)

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

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

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

It is important to initialize ALL variables, including pie:

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

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

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

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

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

(* ************************************************************************ *)
(* end module package.getocp version = 7.70; {of delmod.p 2005 Sep 15} *)

(* begin module book.getbase *)
function getbase(position: integer; pie: pieceptr):base;
(* Get a base from the position (internal coordinates) of the
   piece.  Protection is made against positions outside the piece.
In the case of circles it would be convenient to wrap around when
requests are off the end.  So the routine will do a modular
wrap for positions outside the range 1 to the length.
This is a new feature as of 2000 March 22.
*)
var
   workdna: dnaptr; (* pointer to the dna part of pie *)
   p: integer; (* current count of bases into the workdna *)
   spot: integer; (* the last base of the dna part *)
   thelength: integer; (* the length of the piece *)
begin
{
writeln(output,'NEW getbase: position=',position:1,'^^^^^^^^^^^^^^^^^^^^');
}
   (* handle cases of position out of range by circular wrapping *)
   thelength := piecelength(pie);
   while position < 1         do position := position + thelength;
   while position > thelength do position := position - thelength;

   workdna:=pie^.dna;
   p:=workdna^.length;
   while position > p do begin
{
writeln(output,' workdna^.length=',workdna^.length:1);
}
      workdna := workdna^.next;
      if workdna = nil then begin
        writeln(output,'error in function getbase!');
        halt
      end;
      p := p + workdna^.length;
   end;
{
writeln(output,'p=',p:1);
}
   if workdna = nil then begin
      writeln(output,'error in getbase: request off end of piece');
      halt
   end
   else begin
      spot := workdna^.length - (p-position);
{
writeln(output,'spot=',spot:1);
showdnasegment(output,workdna, spot);
}
      if (spot <= 0) then begin
         writeln(output,'error in getbase, spot (= ',spot:1, ') must be positive');
         halt
      end;
      if (spot > workdna^.length) then begin
         writeln(output,'error in getbase, spot (=',spot:1,
                        ') must be less than length (=',workdna^.length:1,')');
         halt
      end;
{
writeln(output,'base = ', workdna^.part[spot]);
}
      getbase:=workdna^.part[spot]
   end
end;
(* end module book.getbase version = 7.70; {of delmod.p 2005 Sep 15} *)


(* begin module book.iwname *)
procedure iwname(var thefile: text; thename: name);
(* write the name to the file *)
var   c: integer;
begin
      for c:=1 to thename.length
         do write(thefile, thename.letters[c])
end;
(* end module book.iwname version = 7.70; {of delmod.p 2005 Sep 15} *)
(* begin module book.iworg *)
procedure iworg(var afile: text; org: orgkey);
(* write an organism specification.  no writeln is done to allow
   write orgchr to do this. *)
begin
      write(afile,'organism ');
      iwname(afile,org.hea.keynam);
      write(afile,';');
end;
(* end module book.iworg version = 7.70; {of delmod.p 2005 Sep 15} *)
(* begin module book.iwchr *)
procedure iwchr(var afile: text; chr: chrkey);
(* write an chromosome specification.  no writeln is done to allow
   write orgchr to do this. *)
begin
      write(afile,'chromosome ');
      iwname(afile,chr.hea.keynam);
      write(afile,';');
end;
(* end module book.iwchr version = 7.70; {of delmod.p 2005 Sep 15} *)
(* begin module book.iworgchr *)
procedure iworgchr(var afile: text;
                       org: orgkey; orgchange, orgopen: boolean;
                       chr: chrkey; chrchange, chropen: boolean);
(* write both organism and chromosome specifications, based
on whether the organism or chromosome changed (orgchange and chrchange)
and whether they are currently open (orgopen, chropen).
See getocp in the br routines. *)
begin
   if orgchange and orgopen then iworg(afile,org);
   if orgchange and chrchange and orgopen and chropen then write(afile,' ');
   if chrchange and chropen then iwchr(afile,chr);
   if (orgchange and orgopen) or (chrchange and chropen) then writeln(afile)
end;
(* end module book.iworgchr version = 7.70; {of delmod.p 2005 Sep 15} *)

(* begin module amino.getaminoacid *)
procedure getaminoacid(position: integer; pie: pieceptr;
                       var aa: aminoacid);
(* get the amino acid corresponding to a codon starting in pie at position.
   the amino acid is blank ('   ') if it is outside a linear piece.
   amb = amber nonsense (uag)
   och = ochre nonsense (uaa)
   opa = opal  nonsense (uga)
*)
var
      b0, b1, b2: base; (* bases that correspond to the amino acid *)
      length: integer; (* length of the piece *)
      done: boolean; (* flag for out of bounds test *)
begin
      length:=pietoint(pie^.key.pieend,pie);
      done:=false;

      (* deal with position out of the piece *)
      if (position < 1) or (position > length - 2)
      then case pie^.key.piecon of
         linear: begin (* ignore out of bounds requests *)
            aa:='   ';
            done:=true
         end;
         circular: begin (* modify the local copy of position
                            to be within the circle. *)
            while position < 1 do position:=position + length;
            while position > length do position:=position - length;

            b0:=getbase(position,pie);

            (* step through the codon, making sure to stay on the circle. *)
            position:=succ(position);
            if position > length then position:=1;
            b1:=getbase(position,pie);

            position:=succ(position);
            if position > length then position:=1;
            b2:=getbase(position,pie);
         end
      end
      else begin (* pick up the bases at the position *)
         b0:=getbase(position+0,pie);
         b1:=getbase(position+1,pie);
         b2:=getbase(position+2,pie);
      end;
      if not done then case b0 of
         t: case b1 of
            t: case b2 of
               t: aa:='phe';
               c: aa:='phe';
               a: aa:='leu';
               g: aa:='leu';
            end;
            c: case b2 of
               t: aa:='ser';
               c: aa:='ser';
               a: aa:='ser';
               g: aa:='ser';
            end;
            a: case b2 of
               t: aa:='tyr';
               c: aa:='tyr';
               a: aa:='och';
               g: aa:='amb';
            end;
            g: case b2 of
               t: aa:='cys';
               c: aa:='cys';
               a: aa:='opa';
               g: aa:='trp';
            end;
         end;
         c: case b1 of
            t: case b2 of
               t: aa:='leu';
               c: aa:='leu';
               a: aa:='leu';
               g: aa:='leu';
            end;
            c: case b2 of
               t: aa:='pro';
               c: aa:='pro';
               a: aa:='pro';
               g: aa:='pro';
            end;
            a: case b2 of
               t: aa:='his';
               c: aa:='his';
               a: aa:='gln';
               g: aa:='gln';
            end;
            g: case b2 of
               t: aa:='arg';
               c: aa:='arg';
               a: aa:='arg';
               g: aa:='arg';
            end;
         end;
         a: case b1 of
            t: case b2 of
               t: aa:='ile';
               c: aa:='ile';
               a: aa:='ile';
               g: aa:='met';
            end;
            c: case b2 of
               t: aa:='thr';
               c: aa:='thr';
               a: aa:='thr';
               g: aa:='thr';
            end;
            a: case b2 of
               t: aa:='asn';
               c: aa:='asn';
               a: aa:='lys';
               g: aa:='lys';
            end;
            g: case b2 of
               t: aa:='ser';
               c: aa:='ser';
               a: aa:='arg';
               g: aa:='arg';
            end;
         end;
         g: case b1 of
            t: case b2 of
               t: aa:='val';
               c: aa:='val';
               a: aa:='val';
               g: aa:='val';
            end;
            c: case b2 of
               t: aa:='ala';
               c: aa:='ala';
               a: aa:='ala';
               g: aa:='ala';
            end;
            a: case b2 of
               t: aa:='asp';
               c: aa:='asp';
               a: aa:='glu';
               g: aa:='glu';
            end;
            g: case b2 of
               t: aa:='gly';
               c: aa:='gly';
               a: aa:='gly';
               g: aa:='gly';
            end;
         end;
      end;
end;
(* end module amino.getaminoacid version = 7.70; {of delmod.p 2005 Sep 15} *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

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

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

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

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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;
            o := o^.next;
         end;
         o := mothers;
         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 has no MOTHERS.');
      end;

   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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

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

{444}
(* 2007 Mar 15: the locatefeature function was moved up here
so it could be called in writeaminoacids.  Other similar functions
should also be moved. *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module locatefeaturebyname *)
procedure locatefeaturebyname(aname: string;
{                        coo: real;}
                        afeaturelist: featuretypeptr;
                        var thefeature: featuretypeptr;
                        StopAtTotal: boolean);
{NOTE: this procedure is NOT used currently!}
(* Locate the feature corresponding to aname and NOT by coordinate coo
in the afeaturelist.  The coordinate should NOT be used because
the coordinates are external and subtractions are not appropriate.
---
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, afeaturelist) must be determined by the
calling routines to begin at the start of the cluster. *)
var
   done: boolean; (* are we done searching for the feature? *)
begin
writeln(output, 'procedure locatefeaturebyname(aname: string;');{ halt;}
   thefeature := afeaturelist;
   done := false;
   repeat
write(output,'locatefeaturebyname loop: thefeature = ');
writeafeature(output,thefeature);
writeln(output);
      if thefeature = nil
      then begin
         write(output,'locatefeaturebyname FAILED to find ');
         writestring(output,aname);
         writeln(output);
         halt;
      end
      else begin
         (* is it the one we want? *)
   {
write(output,'locatefeaturebyname: 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
}
            if not thefeature^.usedInGroup
            then begin
               thefeature^.usedInGroup := true;
writeln(output,'GOT thefeature ==============================');
writeafeature(output,thefeature);
{uuuuuuuuuu}
               done := true;
            end
            else thefeature := thefeature^.next
         end
         else if thefeature^.definition^.istotal and StopAtTotal   
         then begin
             (* we found the total and not the feature *)
writeln(output,'GOT TOTAL==============================');{ halt;}
             thefeature := nil
         end
         else thefeature := thefeature^.next
      end
   until done;
end;
{mmm}
(* end module locatefeaturebyname version = 0.00; (@ of prgmod.p 2016 Aug 04 *)

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

procedure writeblanks(var afile: text; blanks: integer);
(* send blanks to a file *)
var
      counter: integer;
begin
      if blanks>0
         then for counter:=1 to blanks do write(afile,' ')
end;

procedure MBwriteblanks(var afile: text; blanks: integer);
(* send blanks to a file, using the MB routine *)
begin
   if blanks > 0
   then write(afile, ' ', blanks:1, ' MB');
end;

procedure MBstoreblanks(blanks: integer; var blankcount: integer);
(* Store up some blanks in blankcount *)
begin
   blankcount := blankcount + blanks;
end;

procedure MBdumpblanks(var afile: text; var blankcount: integer);
(* Dump all the blanks counted up in blankcount to afile,
reset blankcount *)
begin
   MBwriteblanks(afile, blankcount);
   blankcount := 0;
end;

procedure pagemark(var afile: text);
(* put a page mark to the file.  This can often be done with the
standard pascal function page *)
begin
   case pageaction of
      'l': begin
         (* method for ending pages in LaTeX: *)
         writeln(afile,'\end{verbatim}');    (* end the previous verbatim *)
         writeln(afile,'\newpage');          (* jump to the next page *)
         writeln(afile,'\begin{verbatim}');  (* start a new verbatim *)
      end;
      'c': begin (* standard function: *)
         page(afile); write(afile,'*');
      end;
      'n': begin
         (* do nothing *)
      end;
   end
end;

procedure writepagenumber(var afile, map: text; mapcontrol: boolean;
                          var pagenumber, halfpagewidth: integer);
(* write out the current page number *)
begin
      (* write out page number *)
      if (decapitalize(pagetrigger) = pagetrigger) then begin
         writeblanks(afile,halfpagewidth);
         writeln(afile,'- ',pagenumber:1,' -');
      end;

      if mapcontrol then begin
{2001 jan 17: I think this was misplaced - remove
         writeblanks(afile,halfpagewidth);
}
         if pagenumber >= 2 then writeln(map,'endpage');
         writeln(map); (* separate this page from previous page *)
         writeln(map,'%%Page: ',pagenumber:1,' ',pagenumber:1);
         writeln(map,'startpage');
         if (decapitalize(pagetrigger) = pagetrigger) then begin
{
            write(map,'(');
}
            if pageaction <> 'n'
            then begin
               MBwriteblanks(map,halfpagewidth);
               write(map,' (- ',pagenumber:1,' -');
               writeln(map,') s n');
            end
         end;
      end;
end;

procedure nextpage(var afile, map: text; mapcontrol: boolean;
                   var linenumber, pagenumber, halfpagewidth: integer);
(* start a new page to afile, if the given linenumber is right.
Put the pagenumber on the page at halfpagewidth.
If mapcontrol, page the map. *)
begin
   (* only page when we are not at the top of a page *)
   if pageaction <> 'n' then if linenumber > 3 then begin
      pagemark(afile);
      pagenumber:=succ(pagenumber);

      writepagenumber(afile, map, mapcontrol,
                      pagenumber, halfpagewidth);
      linenumber:=2;
   end
end;

{********************************************************************}

{kkk}

function computeacolor(f: featuretypeptr; colorvalue: real): real;
(* Compute the color for the feature.  If the colorvalue is
positive, use that color value.  If it is negative,
compute it according to the Ri and consensus.
kkk
FUTURE: compute could be controlled by a character flag:
  r = use Ri
  b = black to white value ...
Tparam is ' ' and use low, mid, high from Aparam, Bparam and Cparam
to get the scaling
*)
const computeacolordebugging = false;
var
   consensus: real; (* The strongest possiblle individual information *)
   Ri: real; (* The individual information of the entire site *)
   newcolorvalue: real; (* the actual colorvalue written out *)
begin
   with f^.definition^.petal do begin
      if colorvalue >= 0.0
      then begin
         computeacolor := colorvalue
      end
      else begin
         Ri :=        f^.Ri;
         consensus := f^.definition^.matrix^.consensus;
         if Ri >= 0
         then newcolorvalue := Ri*abs(colorvalue)/consensus
         else newcolorvalue := 0.0;
         if newcolorvalue > 1.0 then newcolorvalue := 1.0;
         computeacolor := newcolorvalue;
if computeacolordebugging then begin
writeln(output);
writeln(output, 'computeacolor: colorvalue = ',colorvalue:pwid:pdec);
writeln(output, 'Ri = ', Ri:pwid:pdec,
                ' consensus = ', consensus:pwid:pdec,
                ' Ri/consensus = ', (Ri/consensus):pwid:pdec);
writeafeature(output, f);
writeln(output);
end;
      end;
   end;
end; (* computeacolor *)

(* begin module clearfeaturememory *)
procedure clearfeaturememory(var fm: featurememoryarray);
(* clear a feature memory *)
var
   l: integer; (* index to the memory *)
begin
{vvv}
   for l := 1 to linemax do begin
      fm[l].feature := nil;
      fm[l].state := 0.0;
      fm[l].next := nil;
   end;
end;
(* end module clearfeaturememory *)

(* begin module writefeaturememory *)
procedure writefeaturememory(var afile: text; fm: featurememoryarray);
(* Write a feature memory to a file.  Two lines are used.  The first
has a carriage return and the second does not so that the user
can put a name on it.  In the first line the underscore '_' indicates
a nil pointer, 't' is a total feature and 'G' is a Gap feature.
The routine uses the global actualmax to determine the actual
maximum line size to write to. *)
var
   l: integer; (* index to the memory *)
begin
{vvv}

   for l := 1 to actualmax do begin
      if fm[l].feature = nil
      then write(afile,'_')
      else begin
         if fm[l].feature^.definition^.ismulti
         then begin
            if fm[l].feature^.definition^.istotal
            then write(afile,'t');
            if fm[l].feature^.definition^.isgap
            then write(afile,'G');
         end
         else write(afile,'^');
      end;
   end;
   writeln(afile,' ',actualmax:1);
{uuu}

   for l := 1 to actualmax do begin
      if (fm[l].state > 0) and (fm[l].state < 1)
      then write(afile,'/')
      else write(afile,round(fm[l].state):1)
   end;

{
   (* show all the features on the line *)
   for l := 1 to actualmax do begin
      if fm[l].feature <> nil
      then begin
         write(afile,' ',l:3,' ');
         if fm[l].feature^.definition^.ismulti
         then begin
            if fm[l].feature^.definition^.istotal
            then write(afile,'t');
            if fm[l].feature^.definition^.isgap
            then write(afile,'G');
         end
         else write(afile,'^');
         write(afile,' ');
         writeafeature(afile, fm[l].feature);
         writeln(afile);
      end;
   end;
}

end;
(* end module writefeaturememory *)

{yyy final}

(* begin module stepvm *)
procedure stepvm(f: featuretypeptr; lineplace: integer; featurespot: real);
(* Initially, set the verticalmemory at lineplace and be the number
of parts in the multipart feature f.

Then for the next feature, step the vertical memory down.  The
vertical memory at lineplace decays towards zero every time one of the
vertical components is found.  The states of the vertical memory
keep track of how far to draw the vertical line.

vmmax is the *horizontal* position
of the highest vertical line to handle.

2016sep05: Total lines don't count and should not change the vertical
line processing.  If included they lead to black boxes for objects
with less than 0 verticalmemory[].states.  Hence there is an initial
if that blocks them.

2016 Oct 08:
If we are NOT keeping duplicates, then don't count
the duplicates for the vertical bar!

featurespot is the coordinate of the feature.
This is useful for figuring out which end of a gap
we are working on.

*)
const
   vdebugging = true; (* turn on tracing *)
var
   done: boolean; (* finished scanning for edge of used vm *)
                  (* done finding zero feature of gap feature *)
   q: featurecarrierptr; (* pointer to the mothers *)
   MotherOtherCount: integer; (* number of mothers and others *)
   foundfeature: featuretypeptr; (* the end of a gap to be used
      for vertical bar *)
begin (* stepvm *)
if superdebug then begin
writefeaturememory(output,verticalmemory); writeln(output,'<-BEGIN stepvm');
end;

if round(verticalmemory[lineplace].state) < 0 then begin (* safety check *)
writeln(output,'stepvm: failed: negative vertical memory');
writefeaturememory(output,walkermemory  ); writeln(output,'<- walkermemory');
writefeaturememory(output,verticalmemory); writeln(output,'<- verticalmemory');
halt;
end;

if not f^.definition^.istotal then begin (* ignoring total lines ITL *)
   if round(verticalmemory[lineplace].state) < 2 then begin
{vvv}
      case round(verticalmemory[lineplace].state) of
         0: begin (* start the vertical memory *)
            if lineplace > vmmax then vmmax := lineplace;
            MotherOtherCount := 0;

            if not f^.definition^.isgap then begin (* non-gap feature *)
               verticalmemory[lineplace].feature := f;

               (* non-gap features: *)
               q := f^.mothers;
               while q <> nil do begin
                  (* ignoring total lines ITL *)
                  if not q^.afeature^.definition^.istotal (* allow gap *)
                  then begin
                     (* 2016 oct 08: If we are NOT keeping duplicates,
                        then don't count the duplicates for the vertical bar!
                           q^.afeature^.duplicateprevious = nil
                        is true when there are no duplicates *)
                     if KeepDuplicates or (q^.afeature^.duplicateprevious = nil)
                     then MotherOtherCount := MotherOtherCount + 1;
                  end;
{writeln(output, 'inside loop 1 MotherOtherCount = ', MotherOtherCount:1);}
{writeafeature(output,q^.afeature); writeln(output);}
                  q := q^.next;
               end;
               if MotherOtherCount = 0 then begin (* safety check *)
                  writeln(output,'*** Failed to find and count mothers for:');
                  showafeature(output,f);
                  halt;
               end;
            end

            else begin (* GapFeatures *)
               (* Count the mothers of the feature of this gap
                  at the coordinate featurespot. *)

               (* safety tests *)
               if f^.others = nil then begin
                  writeln(output,'This Gap feature does not point to anything!');
                  writeln(output,'stepvm: f^.others = nil');
                  writeafeature(output,f); writeln(output);
                  showafeature(output,f);
                  halt;
               end;
               if f^.others^.afeature = nil then begin
                  writeln(output,'stepvm: f^.others^.afeature=nil');
                  halt;
               end;

               (* TODO: we need to distinguish the two ends of the gap!!! *)
               (* First find the feature whose coordinate matches this
                  gap's zero coordinate, featurespot *)
{writeln(output,'BUBBA in gap 1');}
{writeln(output,'BUBBA in gap 2, featurespot = ',round(featurespot):1);}
{writeln(output,'BUBBA in gap 2.1 for this gap: f=');}
{showafeature(output,f);}

{writeln(list,'BUBBA featurespot = ', round(featurespot):1);}
               (* Find the feature the gap points to at featurespot: *)
               q := f^.others;
{vvv2018mar15}
{
if not featuresForward then q := featurelist;
Incompatible types: got "featuretypeptr" expected "featurecarrierptr"
}
               done := false;
               while not done do begin
                  if q^.afeature^.coordinate = featurespot
                  then done := true
                  else q := q^.next;
                  if q = nil then begin
                     writeln(output,'*******************************************');
                     writeln(output,'stepvm: failed to find feature for gap zero');
                     writeln(output,'while looking for featurespot = ',
                                     round(featurespot):1);
                     writeln(output,'in the others of this feature #',
                                    f^.featurenumber:1,':');
                     writeafeature(output,f);
                     writeln(output);
                     writeln(output,'----------');
                     showafeature(output,f);
                     rewrite(list); showfeatures(list, featurelist, true);
{FLIP}
                     writeln(output,'*******************************************');
                     writeln(output,'**** features overwritten to list file ****');
                     writeln(output,'*******************************************');
                     halt;
                  end;
               end;
               foundfeature := q^.afeature;
{writeln(output,'BUBBA in gap 2.2 THE found q:');}
{writeafeature(output, q^.afeature); writeln(output);}

               (* Reset q to be the mother list of the q feature,
                  then count the mothers of this feature. *)
               q := q^.afeature^.mothers;
               while q <> nil do begin
                  (* ignoring total lines ITL *)
                  if not q^.afeature^.definition^.istotal
                  then begin
{
if (q^.afeature^.duplicateprevious = nil) then
}
                     MotherOtherCount := MotherOtherCount + 1;
                  end;
{writeln(output, 'inside loop 1 MotherOtherCount = ', MotherOtherCount:1);}
{writeafeature(output,q^.afeature); writeln(output);}
                  q := q^.next;
               end;
               verticalmemory[lineplace].feature := foundfeature;
            end; (* GapFeatures *)

            (* point at the feature we found! *)
            verticalmemory[lineplace].state := MotherOtherCount;

            if verticalmemory[lineplace].state < 0 then begin
               writeln(output,'stepvm MOMFAIL: verticalmemory went negative!');
               halt;
            end;
         end;

         1: begin (* the verticalmemory has 1 at this location.
                     set it to zero and clear the pointer *)
            verticalmemory[lineplace].state := 0;
            verticalmemory[lineplace].feature := nil;
{vvv2018mar15 new:}
            verticalmemory[lineplace].next := nil;
            if lineplace = vmmax then begin
               (* locate the next lower place to the left for vmmax *)
               done := false;
               while not done do begin
                  if vmmax = 0
                  then done := true
                  else if verticalmemory[vmmax].state <> 0
                       then done := true
                       else vmmax := vmmax - 1;
               end;
            end;
         end;

      end
   end (* cases 0 and 1 *)
   else begin (* cases 2 and higher - just decay *)
      verticalmemory[lineplace].state
      := verticalmemory[lineplace].state - 1;
{vvv2018mar15 new: remove current feature from the linked list?}

if superdebug then begin
 writeln(output,'decrease verticalmemory at ',lineplace:1,
 ' to ',round(verticalmemory[lineplace].state):1);
 if verticalmemory[lineplace].state < 0 then begin
  writeln(output,'STEPPED BELOW ZERO!');
  (* this does not happen *)
  halt;
 end;
end

   end;
if superdebug then begin
writefeaturememory(output,verticalmemory); writeln(output,'<-END stepvm');
end;

end (* ignoring total lines ITL *)
else begin (* maybe should clear it when we finally see the total????
NO! That breaks when one p35 has multiple -10s *)
{
   verticalmemory[lineplace].state := 0;
   verticalmemory[lineplace].feature := nil;
}
end;

end; (* stepvm *)
(* end module stepvm *)

(* begin module doshift *)
procedure doshift;
(* apply the shift instructions to move the text to the right *)
var
   blanks: integer; (* number of blanks written out so far *)
begin
   if firstone then begin (* shift the line over if needed *)
      if shiftsequence > 0 then begin
         for blanks := 1 to shiftsequence do write(list,'  ');
         writeln(map,'% shift sequence');
         MBwriteblanks(map, 2*shiftsequence);
         writeln(map);
      end;
   end;
end;
(* end module doshift *)

procedure nextline(var afile, map: text; mapcontrol: boolean;
                   notwalkerlines: boolean;
                   var linenumber, pagenumber, halfpagewidth: integer;
                   var blankcount: integer;
                   line: linetype);
(* This routine does (almost) all writelns.
2004 Aug 9: introduce line variable so that currently written
characters can be accounted for. *)
(* notwalkerlines is true if we are not writing blanks for spacing walkers
out.  This makes the list file (ie afile here) more compact. *)
const
{VVVzzz}
   debuggingnextline = false; (* set to true to see the verticalmemory (as
                         numbers) and the walkermemory (as characters)
                         2016sep05: this is now controlled by superdebug *)
var
   i: integer; (* index to the verticalmemory line *)
   colonswritten: boolean; (* vvv *)
   hue, saturation, brightness: real; (* the color *)

begin (* nextline *)
if superdebug then begin
writeln(output,'nextline BEGIN');
end;

   totallineswritten := succ(totallineswritten);
   colonswritten := false;
   if mapcontrol then begin
{vvvhhh}

      (* space before n (start new line) to be safe *)
      writeln(map,' n % nextline');
blankcount := 0; (* clear blank counts???? vvv 2004aug10 *)
   end;

   if notwalkerlines or colonswritten then begin
      writeln(afile);
      if superdebug then begin
         if debuggingnextline then write(afile,linenumber:2,'>');
      end;
   end;

   linenumber:=succ(linenumber);
   (* the test is to SUBTRACT lowerbound because lowerbound
      is a negative value. *)
   if linenumber - lowerbound > pagelength
   then nextpage(afile, map, mapcontrol,
                    linenumber,pagenumber,halfpagewidth);

{vvv}

{NOTE THAT BLANK COUNT IS ONLY USED TO SKIP, NO VALUE MEANS ANYTHING!
That's because we are at the end of a line so blanks left over don't
mean anything.  SO blankcount can be replaced in the call by a boolean
instead.}

   (* We are now on a new line. *)
if superdebug then begin
write  (output,'nextline linenumber = ', linenumber:2 );
writeln(output,' vmmax = ',vmmax:3);
writefeaturememory(output,verticalmemory); writeln(output,'<-NEXTLINE');
(* write the line number information on the left edge of the map: *)
writeln(map,'(',linenumber:3,') s');
writeln(map,'(',vmmax:3,') s');
{
if vmmax = 0 then vmmax := 50;
if vmmax = 0 then vmmax := 120;
if vmmax = 0 then vmmax := 130;
}
end;

   (* Write the vertical memory as a vertical line as a colored rectangle.
      This is done here in nextline before anything else
      has been written, so the line will lie UNDER other things.
      However, walkers from PREVIOUS lines must be protected too. *)
   if (blankcount <> -1) then begin
{writeln(output,'nextline 1 NENENENENENENENENENE');}
      writeln(map,'gsave');
      i := 1;
      blankcount := 0;
      while (i <= vmmax) do begin
         (* If (there is no vertical memory) OR
               (there is a walker is in this region)
            then make a blank to space to the right.
            else make the vertical line *)
         if (round(verticalmemory[i].state) = 0) or
            (walkermemory[i].state > 0)
{attempt to block color verticalmemory on total:
         if ((round(verticalmemory[i].state) = 0) or
             (walkermemory[i].state > 0))
or
(verticalmemory[i].feature^.definition^.istotal)
}
         then begin (* write blanks out *)
{uuu}

if not superdebug then begin
            MBstoreblanks(1, blankcount); (* normal code *)
            writeln(map,'( ) s');         (* normal code *)
end
else begin
MBdumpblanks(map, blankcount); (* like normal code *)
if (round(walkermemory[i].state) > 0) then begin
   hue := 0.5;
   saturation := 0.0;
   brightness := 1.0;
{
   MBdumpblanks(map, blankcount);
}
   writeln(map,
   ' ', hue:pwid:pdec,
   ' ', saturation:pwid:pdec,
   ' ', brightness:pwid:pdec, ' sethsbcolor');
   (* write the walker memory as a character *)
   writeln(map,'(',
     (chr(round(walkermemory[i].state)+ord('a')-1)):1,') s');
end
else begin
{
   if round(verticalmemory[i].state) > 0 then begin
this is done below here
      writeln(map,'(', round(verticalmemory[i].state),
                  ') s'); (* replace normal code *)
   end
   else begin
}
      writeln(map,'(!) s'); (* replace normal code *)
{
   end
}
end;

            end
         end

         else begin (* write the vertical line out *)
{
else
if not verticalmemory[i].feature^.definition^.istotal
then begin
            MBdumpblanks(map, blankcount);
if verticalmemory[i].feature^.definition^.istotal
then dovertical := false;
dovertical := false;
}
{this did not stop the coloring of the total ends!
if verticalmemory[i].feature^.definition^.istotal
then begin writeln(output,'tried to do istotal!');halt; end;
}
            if dovertical then begin
               (* compute color of the vertical line!! *)
               hue :=
                   computeacolor(verticalmemory[i].feature,
                   verticalmemory[i].feature^.definition^.petal.fh);
               saturation :=
                   computeacolor(verticalmemory[i].feature,
                   verticalmemory[i].feature^.definition^.petal.fs);
               brightness :=
                   computeacolor(verticalmemory[i].feature,
                   verticalmemory[i].feature^.definition^.petal.fb);

               writeln(map,
                            hue:pwid:pdec,
                       ' ', saturation:pwid:pdec,
                       ' ', brightness:pwid:pdec, ' sethsbcolor');
{VVVzzz}
               (* 2016aug31 this call creates the vertical lines: *)
doshift; {vvzz}

               writeln(map, '( ) ', (* 2016aug31 add 'ln' *)
                   verticalbarwidth:pwid:pdec,  (* width of the bar *)
                   verticalbarheight:pwid:pdec, (* height of the bar *)
                   ' letterrectangle');
               if round(verticalmemory[i].state) > 0 then begin
                  if superdebug then begin
                     (* write the vertical memory state instead of the char *)
                     hue := 0.0;
                     saturation := 0.0;
                     saturation := 1.0;
                     writeln(map,
                     ' ', hue:pwid:pdec,
                     ' ', saturation:pwid:pdec,
                     ' ', brightness:pwid:pdec, ' sethsbcolor');
                     writeln(map,' (',round(verticalmemory[i].state):1,') s');
                  end
                  else begin (* normal code *)
                     if (artmode = 'a') or (artmode = 'b') or (artmode = 'B')
                     then writeln(map,' ( ) s') (* 2016sep02 *)
                     else writeln(map,' (',verticalbarcharacter,
                                       ') s'); (* 2016aug31 add '(|)' *)
                  end;
               end;

            end (* if dovertical *)
            else writeln(map,' ( ) s');
         end;
         i := i + 1;
      end;
      writeln(map,'grestore');
   end;

   (* let the verticalmemory decay *)
{uuu this is done (apparently) only in stepvm}

   (* let the walkermemory decay *)
   i := wamax;
   while (i > 0) do begin
      if walkermemory[i].state > 0
      then begin
         walkermemory[i].state := walkermemory[i].state - 1;
         if (i = wamax) and (walkermemory[i].state = 0)
         then begin
            wamax := wamax - 1;
            (* note:  this should slide down to the next one! *)
         end;
      end;
      i := i - 1;
   end;

end; (* nextline *)

{********************************************************************}

(* doshift original location *)

procedure aawrite(var afile: text; aa: aminoacid);
(* write the amino acid to a file.  Use single notation if
requested to. *)
var c: char; (* the amino acid in single letter code *)
begin
   if codelength = 3
   then write(afile,aa)
   else if codelength = 1 then begin

           if aa = 'asp' then c := 'D'
      else if aa = 'glu' then c := 'E'
      else if aa = 'asn' then c := 'N'
      else if aa = 'gln' then c := 'Q'
      else if aa = 'lys' then c := 'K'

      else if aa = 'arg' then c := 'R'
      else if aa = 'his' then c := 'H'
      else if aa = 'pro' then c := 'P'
      else if aa = 'thr' then c := 'T'
      else if aa = 'ser' then c := 'S'

      else if aa = 'cys' then c := 'C'
      else if aa = 'ala' then c := 'A'
      else if aa = 'gly' then c := 'G'
      else if aa = 'tyr' then c := 'Y'
      else if aa = 'trp' then c := 'W'

      else if aa = 'phe' then c := 'F'
      else if aa = 'leu' then c := 'L'
      else if aa = 'ile' then c := 'I'
      else if aa = 'met' then c := 'M'
      else if aa = 'val' then c := 'V'

      else if aa = 'amb' then c := '.'
      else if aa = 'och' then c := '.'
      else if aa = 'opa' then c := '.'

      else if aa = '   ' then c := ' '

      else                    c := '!';

      write(afile,c);
   end
   else begin
      writeln(output,'aawrite error');
      halt
   end;
end;

procedure likesetcolors(var map: text; afeature: featuretypeptr);
{444}
(* set the colors according to Tparam of a feature to file map *)
var
   t: char; (* The Tparam for this feature *)
begin
{
writeln(output,'IN likesetcolors');
}
   if afeature = nil then begin
      writeln(output,'likesetcolors: afeature is nil');
      halt;
   end;
   t := afeature^.Tparam;
{
writeln(output,'IN likesetcolors: t = "',t,'"');
}
   if t in ['h','r','H','R'] then begin
{uuuqqq}
{
writeln(output,'setcolors using t=',t);
writeln(map,'BEFORE ) s 0 1 0 setrgbcolor'); write(map,'(HELLO');
writeln(map,') s 0 0 1 setrgbcolor'); write(map,'(');
}
      write(map,
                afeature^.Aparam:pwid:pdec,
                afeature^.Bparam:pwid:pdec,
                afeature^.Cparam:pwid:pdec);
      case t of
         'h','H': writeln(map,' sethsbcolor');
         'r','R': writeln(map,' setrgbcolor');
      end;
   end;
end;

procedure writeaminoacids(var afile, map: text; mapcontrol: boolean;
                          pie: pieceptr;
                          first, last, frame: integer;
                          var framestate: state;
                          var framecodoncount: integer;
                          var line: linetype;
                          InitiationRegionName: string;
                          giveframes: boolean;
                          featurelist: featuretypeptr;
var thefeature: featuretypeptr; (* feature pointer for this frame! *)
var emphasis: state; (* whether to emphasize this orf *)
var hue:        real; (* hue        for this open reading frame *)
var saturation: real; (* saturation for this open reading frame *)
var brightness: real  (* brightness for this open reading frame *)
                          );
(* Show in afile the amino acids corresponding to
   pie, starting at coordinate first, and going to coordinate last.
   shift by the amount frame (0, 1 or 2) in bases.
   If framestate is on, then the aa's are shown.
   The global aastate is assumed to be either 1 or 2.
   2007 Mar 15: ORF DISPLAY: Include the featurelist now for searching
   for ir features.  Emphasis is turned on only
   when there is a frame on (framestate = on) AND an ir feature
   is at this coordinate in the right orientation.
   InitiationRegionName is a string that defines the name of features
   that should trigger emphasis.
   framecodoncount counts the codons observed when the frame state
   is on.
   The giveframes variable overrides emphasis supression of amino
   acid listings.
{444}
*)
const
   debugging = false; (* show debugging information *)
   framedebug = false; (* show debugging information for frames *)
var
   index: integer; (* coordinate location in this sequence *)
   aa: aminoacid;

{444}
   (* variables for locatefeature *)
   coo: real; (* real version of the index *)
{
   thefeature: featuretypeptr; (* feature pointer *)
}

procedure aawriteascii(var afile: text; aa: aminoacid);
begin
   if codelength = 1 then write(afile,' ');
   write(afile,' ');
   aawrite(afile,aa);
   write(afile,' ');
   if codelength = 1 then write(afile,' ');
end; (* aawriteascii *)

procedure emphasize(var map: text; length: integer);
(* emphasize a chunck of characters on the map.
Initial testing with an underscore '_' works nicely.
Actually '*' is better because sometimes '_' is covered.
The method is to gsave, write the appropriate number of underscores
or colored boxes and then to grestore to return to the output.
*)
var
   debugging: boolean; (* for debugging *)
   l: integer; (* counter for the length *)
begin
{5555}
{444}
    debugging := true;
    debugging := false;
{write(map,  ') s gsave (____) s grestore ('); initial successful method}
   if emphasis = on then begin

if debugging then begin
      writeln(map,  ') s gsave % emphasize');
      write(map,'(');
      for l := 1 to length do begin
{
         write(map,'_');
}
         write(map,'*');
      end;
      writeln(map,') % emphasize');
      write(map,' s grestore (');
end
else begin

      writeln(map,  ') s % emphasize');
      write(map,' gsave');
      write(map, ' ');
      for l := 1 to length do begin

{
         write(map,' 1 0 1 setrgbcolor'); (* force it to be purple *)
         write(map,' 1 0 0 setrgbcolor'); (* force it to be red *)
         write(map,' 1 0.5 1 sethsbcolor'); (* force it to be pink *)
         write(map,' 1 0.5 1 sethsbcolor'); (* force it to be pink *)
         write(map,' 1 1 0 setrgbcolor'); (* force it to be yellow *)
}
{555}
{444}
{
likesetcolors(map,thefeature);
likesetcolors(output,thefeature);
}

{444555}

         (* 2007 Mar 17: If there are no petals then the emphasis is
         black, covering the amino acid words making them impossible
         to read.  To avoid this, set the emphasis to be grey. *)
         if brightness = 0 then begin
           brightness := 0.75
         end;

         write(map,hue:pwid:pdec);
         write(map,saturation:pwid:pdec);
         write(map,brightness:pwid:pdec);
         writeln(map,' sethsbcolor');
         write(map, ' ( ) ', (* petal character *)
             1.0:pwid:pdec, (* width of the bar *)
{ 1.0 is too big, it overlaps the next one up.
             1.0:pwid:pdec, (* height of the bar *)
}
             0.5:pwid:pdec, (* height of the bar *)
             ' letterrectangle');
         write(map, ' ( ) s '); (* step!! *)
      end;
      write(map,' grestore');
      write(map,' (');
end
   end;
end; (* emphasize *)

procedure aawritecolor(var afile: text; aa: aminoacid);
begin
   if codelength = 1 then write(afile,' ');
   write(afile,' ) s ');
   if (aa = 'amb') or (aa = 'och') or (aa = 'opa')
   then begin
      case codelength of
{333}
            (* a blank character is needed for proper spacing: *)
        1:  write(afile,'stopsign e');
        3:  write(afile,' e stopsign e e ');
        end;
   end
   else aawrite(afile,aa);
   write(afile,' b ( ');
   if codelength = 1 then write(afile,' ');
end; (* aawritecolor *)

begin (* writeaminoacids *)
   aa := '   '; (* initialize the darn thing! *)
   index:=first+frame; (* this is the first base to analyze *)

   doshift; (* global shift of the sequence to the right *)

   writeblanks(afile,2);
   writeblanks(afile,2*frame);
   if ((emphasis = on) or (giveframes)) then begin
      write(afile,' -');  (* start with a dash on the left *)
   end
   else begin
      write(afile,'  ');  (* no start dash on the left *)
   end;
   if mapcontrol then begin
      MBwriteblanks(map,2+2*frame);
      write(map,'( ');
      if ((emphasis = on) or (giveframes)) then begin
         emphasize(map,1);  (* *)
         write(map,'-');  (* start with a dash on the left *)
      end
      else begin
         write(map,' ');  (* no dash on the left *)
      end;
   end;

   while index <= last + frame do begin
      getaminoacid(index,pie,aa);
      if aastate = 1 then begin (* on/off frame setting *)
         if (framestate = on) and ((emphasis = on) or (giveframes)) then begin
            framecodoncount := succ(framecodoncount);
if framedebug then writeln(output, frame:1, ' framecodoncount = ', framecodoncount:1,' ', aa);
         end;

         (* turn frame off? *)
         if (aa='amb') or (aa='och') or (aa='opa')
         then begin
            if framestate = on then begin
               emphasize(map,4); {555}
               framecodoncount := 0;
            end;

            (**) if aa = 'amb' then begin
                    write(afile,'amber');
                    (* Note loss of distinction between the three
                    kinds by using stopsign.  A way around this is to
                    use three colors.  I could not find standards for
                    the three on the web. *)
{ 333 original:     if mapcontrol then write(map,'amber'); }
                    if mapcontrol then aawritecolor(map,aa);
                 end
            else if aa = 'och' then begin
                    write(afile,'ochre');
{ 333 original:     if mapcontrol then write(map,'ochre'); }
                    if mapcontrol then aawritecolor(map,aa);
                 end
            else if aa = 'opa' then begin
                    write(afile,'opal ');
{ 333 original:     if mapcontrol then write(map,'opal '); }
                    if mapcontrol then aawritecolor(map,aa);
                 end;
            emphasis := off;
            framestate := off
         end

         (* turn frame on? *)
{ original:
         else if (aa='met') or
                 ((aa='val') and (getbase(index+2,pie)=g))
         (* logic: all valines start with gu.  we want to be sure that
            only the last base (index+2) is a g, so that only gug"s
            will be counted as starts. *)
}
{
         else if ((aa='met') or (aa='val') and (aa='leu'))
                 and (getbase(index+2,pie)=g)
}
         else if
                 (getbase(index+0,pie) <> c) and
                 (getbase(index+1,pie)  = t) and
                 (getbase(index+2,pie)  = g)
         (* 2007 Mar 16 revised logic to allow aug, gug, uug:
         met val and leu are (A,G,U)UN.  Make sure last
         base is a G.  Looking up bases is expensive, so this
         is faster than checking all three. *)

{333444}

         then begin
            (* The frame is now on so let's see if there is an ir
               feature at this location.  If found, turn on emphasis *)
            (* convert to external coordinates in reals: *)
            coo := inttopie(index, pie);
{writeln(output,'ILLEGAL call to locatefeature 1'); halt;}
            locatefeature(InitiationRegionName, (* ILLEGAL *)
                            coo,
                            featurelist,
                            thefeature, false);
if debugging then write(output, 'the index is ', index:5);
if debugging then write(output, ' coordinate ',coo:5:1,' ');
            if thefeature <> nil then begin
if debugging then writeafeature(output,thefeature);

               (* If emphasis was off, start the frame *)
               if emphasis = off then begin
                  framecodoncount := 1; (* count the initiation codon *)
if framedebug then writeln(output, '=======> found an ir feature for this!');
if framedebug then writeln(output, frame:1, ' framecodoncount = ', framecodoncount:1,
               ' ', aa,' ----fMet');
               end;
               emphasis := on;

               (* capture ir color for this frame *)
{444}
               hue        := computeacolor(thefeature,
                             thefeature^.definition^.petal.fh);
               saturation := computeacolor(thefeature,
                             thefeature^.definition^.petal.fs);
               brightness := computeacolor(thefeature,
                             thefeature^.definition^.petal.fb);

{
writeln(map,'STOP');
}
{444}

            end;
if debugging then writeln(output);

            if ((emphasis = on) or (giveframes)) then begin
               if (framestate = off)  (* if the state was off, show fMet *)
               then if codelength = 1
                  then begin
                     write(afile,  ' fM  ');
                     if mapcontrol then begin
                        emphasize(map,6); {555}
                        write(map,  ' fM  ');
                     end;
                  end
                  else begin
                     write(afile,  'fMet ');
                     if mapcontrol then begin
                        emphasize(map,6); {555}
                        write(map,  'fMet ');
                     end;
                  end
               else begin
                  aawriteascii(afile,aa);
                  if mapcontrol then begin
                     emphasize(map,6); {555}
                     aawritecolor(map,aa);
                  end;
               end;
            end
            else begin (* frame off, no emphasis *)
               write(afile,' ','   ',' ');
               if mapcontrol then write(map,' ','   ',' ')
            end;
            framestate := on;
         end

{333444}
         (* normally we just write the aa: *)
         else if (framestate = on)
                 and ((emphasis = on) or (giveframes))
{BUBBA}

              then begin
                 aawriteascii(afile,aa);
                 if mapcontrol then begin
                    emphasize(map,6); {555}
                    aawritecolor(map,aa);
                 end;
              end
              else begin (* frame off, no emphasis *)
                 write(afile,' ','   ',' ');
                 if mapcontrol then write(map,' ','   ',' ')
              end
      end
      else begin (* aastate = 2 *)
         if ((emphasis = on) or (giveframes))
         then begin
            aawriteascii(afile,aa);
            if mapcontrol then aawritecolor(map,aa);
         end;
      end;
      if (aa <> '   ')
         and ((emphasis = on) or (giveframes))
      then begin (* dash between amino acids *)
         write(afile,'-');
         write(map,'-')
      end
      else begin
         write(afile,' ');
         write(map,' ');
      end;
(*writeln(output,index:1,aa); *)
      index:=index+3 (* up by a codon *)
   end;
   if mapcontrol then begin
      write(map,') s ');
   end;
   nextline(afile,map,mapcontrol,true,
            linenumber,pagenumber,basesperline, dummy,line);
end; (* writeaminoacids *)

(* begin module writenumbers *)
procedure writenumbers(var afile, map: text; mapcontrol: boolean;
                       pie: pieceptr;
                       first, last: integer;
                       line: linetype);
(* write the numbers corresponding to writedna.
   each step of index must write an even number of characters
   to keep track of the dna (base-space-base-space, etc.) *)
var
   blankcount: integer; (* current number of blanks stored up *)
   characters: integer; (* number of characters written *)
   index: integer; (* index of pie *)
   ln10: real; (* natural log of 10 *)
   position: integer; (* true coordinates in pie *)
begin
(*writeln(afile,' numbers');*)
   blankcount := 0;
   if mapcontrol then begin
      writeln(map);
      writeln(map,'% writenumbers');
   end;
   doshift;

   ln10:=ln(10);
{
   if mapcontrol then write(map,'b ('); (* set black color *)
}
   if mapcontrol then writeln(map,'b'); (* set black color *)
   writeblanks(afile,4);
{
   if mapcontrol then MBwriteblanks(map,8); (* original *)
}
   (* 2001 jan 17.  It is not clear why this needed to be changed. *)
   if mapcontrol then begin
      MBstoreblanks(4, blankcount); (* the 4 shifts over to account for the " 5' " *)
   end;

   index:=first;
   while index <= last do begin
      position:=inttopie(index,pie);
      if (abs(position) mod 5) = 0
      then begin (* mark bases with star *)
         if (abs(position) mod 10) = 0
         then write(afile,tenspacemark) (* 2012 Oct 25 *)
         else write(afile,fivespacemark); (* 2012 Apr 18, 2012 Oct 25 *)
         if mapcontrol then begin
            MBdumpblanks(map, blankcount);
            if (abs(position) mod 10) = 0
            then write(map,' (',tenspacemark, ') s') (* 2012 Oct 25 *)
            else write(map,' (',fivespacemark,') s'); (* 2012 Apr 18, 2012 Oct 25 *)
         end;

         (* number every position divisible by 10 *)
         if (abs(position) mod 10) = 0
         then begin (* number *)
            characters:=1; (* account for the star *)
            write(afile,position:1);
{
            if mapcontrol then write(map,position:1);
            if mapcontrol then writeln(map,' (',position:1,') s');
}
            MBdumpblanks(map, blankcount); (* probably none, but no harm *)
            if mapcontrol then writeln(map,' (',position:1,') s');

            (* now figure number of blanks needed
              to make an even number of characters written *)

            (* calculate number of characters printed for position *)
            if position <> 0
            then characters:=trunc(ln(abs(position)+1)/ln10)+1+characters
            else characters:=succ(characters);

            (* logic for position <> 0:
            abs removes any minus sign.
            ln(x)/ln(10) = log to the base 10 of x.
            the +1 with position assures that round off errors do not cause
            the wrong number of spaces to be output.
            (for position=1000, without the +1 i got 2.999999999999857891...
            so that the trunc gave 2.)
            the second +1 accounts for the "1" in "1000".
            this does not cause problems with 99->100 (and having an extra
            digit) because only multiples of 10 are printed. *)

            (* account for a minus sign: *)
            if position < 0 then characters:=succ(characters);

            (* make the number of characters even *)
            if (characters mod 2) <> 0 then begin
               writeblanks(afile,1);
               if mapcontrol then begin
                  MBstoreblanks(1, blankcount);
               end;
               characters:=succ(characters)
            end;

            index:=index + trunc(characters/2)
         end

         else begin (* positions divisible by 5 only get a star *)
            writeblanks(afile,1);
            if mapcontrol then begin
               MBstoreblanks(1, blankcount);
            end;
            index:=succ(index)
         end;
      end
      else begin (* blank *)
         write(afile,'  ');
         if mapcontrol then MBstoreblanks(2, blankcount);
         index:=succ(index)
      end
   end;
{
   if mapcontrol then write(map,') s ');
}
   nextline(afile,map,mapcontrol,true,
            linenumber,pagenumber,basesperline,dummy,line)
end;
(* end module writenumbers *)

(* begin module writedna *)
procedure writedna(var afile, map: text; mapcontrol: boolean;
                   pie: pieceptr;
                   first, last: integer; invert: boolean;
                   line: linetype);
(* write the dna in pie between (inclusive) position first and last.
   one blank is placed between each pair of bases.
   write the complement of the sequence if invert is true. *)
const
   maxbasesperline = 20; (* number of bases put per line in the
      map to prevent really long PostScript lines there *)
var
   index: integer; (* for pie *)
   coo: integer; (* the piece coordinate *)
   b: base; (* the base to be printed *)
   afterslash: boolean; (* after the coordinate slash, don't
      write a space since we just wrote a slash. *)
procedure showends(invert: boolean);
begin
   case invert of
      true:  begin
         write(afile,'3',prime,' ');
         if mapcontrol then writeln(map,'b ( 3',prime,') s');
      end;
      false: begin
         write(afile,'5',prime,' ');
         if mapcontrol then writeln(map,'b ( 5',prime,') s')

      end;
   end;
end;
begin
   if mapcontrol then begin
      writeln(map);
      writeln(map,'% writedna');
   end;
   doshift;
   writeblanks(afile,1);
   showends(invert);
   afterslash := false;
   for index:=first to last do begin
      b := getbase(index,pie);
      if invert then b := complement(b);
      write(afile,basetochar(b));
      if mapcontrol then begin
         if not afterslash then write(map,'e');
         write(map,' ',basetochar(b));
         afterslash := false;
         if ((index - first + 1) mod maxbasesperline) = 0
         then writeln(map)
      end;
      with pie^.key do begin
         (* put a slash at coordinate change *)
         if coocon=circular then begin
            coo:=inttopie(index,pie);
            if ((coo = cooend) and (piedir = plus)) or
               ((coo = coobeg) and (piedir = minus))
            then begin
               write(afile,'/');
               if mapcontrol then write(map,' b (/) s ');
               afterslash := true;
            end
            else begin
               write(afile,' ');
               if mapcontrol then write(map,' ')
            end
         end
         else begin
            write(afile,' ');
            if mapcontrol then write(map,' ')
         end
      end
   end;
   showends(not invert);
   nextline(afile,map,mapcontrol,true,
            linenumber,pagenumber,basesperline,dummy,line)
end;
(* end module writedna *)

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

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module barofnumbers *)
procedure barofnumbers(var afile: text; shiftright, sets: integer);
(* write out a bar of number consisting of a certain
number of sets of 10, shifted right by shiftright.
This is useful for debugging. *)
var
   spot: integer; (* the spot where a mark is written into the line *)
begin
   write(afile,' ':shiftright);
   for spot :=1 to sets do write(afile,'1234567890');
   writeln(afile);
   write(afile,' ':shiftright);
   for spot :=1 to sets do write(afile,'         ',spot:1);
   writeln(afile);
end;
(* end module barofnumbers *)

(* begin module linearpietoint *)
function linearpietoint(p: integer; pie: pieceptr): integer;
(* p is a coordinate on the piece.
   we want to transform p into a number
   from 1 to n: an internal coordinate system for
   easy manipulation of piece coordinates.
   UNLIKE the pietoint, we never compute the number on a circle. *)
(*
2001 Sep 9:
WELL DUH!!!!  this will fail at circular coordinate bounds!
2004 Jul 9:  To remove the gpc complier objection:
"warning: enumeration value `Dircomplement' not handled in switch"
I ASSUME that dircomplement corrsponds to plus and that
dirhomologous corresponds to minus.
*)
var   i: integer; (* an intermediate value *)
begin
{ writeln(output,'linearpietoint: p=',p:1); }
      with pie^.key do begin
         case piedir of
            dircomplement, { ASSUMED to be the right thing }
            plus:  {if p>=piebeg}
                   {then} i:=p-piebeg+1
                   {else i:=(p-coobeg)+(cooend-piebeg)+2};
            dirhomologous, { ASSUMED to be the right thing }
            minus: {if p<=piebeg
                   then} i:=piebeg-p+1
                   {else i:=(cooend-p)+(piebeg-coobeg)+2}
         end;
         linearpietoint:=i
      end
end;
(* end module linearpietoint *)

(* begin module realpietoint *)
function realpietoint(coordinate: real; pie: pieceptr): real;
(* convert the real number piece coordinate to a real number
internal coordinate.

Bug of 2001 Sep 7: call was to
linearpietoint.  But that routine is not set up to handle
circles, so of course it failed at the origin of SV40, which
is at the boundary of a circle.  Solution:  replace call to
linearpietoint with pietoint.

2002 Feb 22
For circular pieces I switched from linearpietoint to pietoint
between version 9.95 and version 9.96.
HOWEVER this cause failure to find the ends of exons.
These were the lines that cause the bug:
   then realpietoint := pietoint(-round(-coordinate),pie) - bitostuff
   else realpietoint := pietoint(+round(+coordinate),pie) + bitostuff;
Using pietoint caused loss of the end of the exon mark.

Probable solution:
How about doing it only for circulars???

2008 Apr 17:
organism E.coli-K12; chromosome E.coli-K12;
piece NC_000913;
name "recA"; get from 2821861 +200 to same -200 direction -;
ygaD exonfeature fails to show up but recA does:
* lexA features
define "NC_000913.ygaD" "-" "<]" "[>" 0 497
@ NC_000913 2822368 -1 "NC_000913.ygaD" ""
define "NC_000913.recA" "-" "<]" "[>" 0 1061
@ NC_000913 2821791 -1 "NC_000913.recA" ""
SOLUTION: switch from pietoint to linearpietoint for circular
chromsomes.  For some reason pietoint did not handle
the coordinate conversion and gave a huge value.

2012 Oct 26:
The final result has to be positive!  So loop while adding
the cooend until that is true.

*)
var
   bitostuff: real; (* 0 or 0.5 (probably) *)
   proposed: real; (* proposed result *)
   coobeg: integer; (* coordinate begin *)
   cooend: integer; (* coordinate end *)
begin
{writeln(output,'realpietoint: input coordinate = ',coordinate:10:1);}
   bitostuff := abs(coordinate) - round(abs(coordinate));
   if pie^.key.coocon = linear then begin
      if (pie^.key.piedir = minus)
      then proposed := linearpietoint(-round(-coordinate),pie) - bitostuff
      else proposed := linearpietoint(+round(+coordinate),pie) + bitostuff;
   end
   else begin
      if (pie^.key.piedir = minus)
      (* 2008 apr 17: switched from pietoint to linearpietoint *)
      then proposed := linearpietoint(-round(-coordinate),pie) - bitostuff
      else proposed := linearpietoint(+round(+coordinate),pie) + bitostuff;
   end;

   if proposed < 1 then begin
      {writeln(output,'LOW proposed: ',proposed:5:1);}
      coobeg := pie^.key.coobeg;
      cooend := pie^.key.cooend;
{
      writeln(output,'coobeg: ',coobeg:10);
      writeln(output,'cooend: ',cooend:10);
      writeln(map,'HALT');
}

      while proposed < 1 do begin
          proposed := proposed + cooend;
      end;
{
      writeln(output,'NEW proposed: ',proposed:5:1);
}
   end;
   realpietoint := proposed;

end;
{
(* 2008 Apr 17: original code, pietoint fails to convert correctly. *)
      then realpietoint := pietoint(-round(-coordinate),pie) - bitostuff
      else realpietoint := pietoint(+round(+coordinate),pie) + bitostuff;
}
(* end module realpietoint *)

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

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)
 
(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)
 
(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)
 
(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)
 
(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)
 
(******************************************************************************)
(* end module makelogo.mark.package version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module writemarks *)
procedure writemarks(var map, marks: text;
                         first, last, shiftsequence: integer);
(* write the marks to map between (inclusive) position first and last onto a
single line.  The marks are relative to the first line of the listing, so mark
positions should usually have negative y (bit) locations.
The user can shift the sequence right for the first line;
this is given in shiftsequence. *)
var
   position: integer; (* position on the line between first and last *)
begin
   writeln(map);
   writeln(map,'% writemarks');
   writeln(map,'gsave');

   (* mm, m2, and mh are defined in startpostscript *)
   (* move a half space to position ourselves precisely at the
      start of the character *)
   writeln(map,'mh');

   (* shift to the right to get to the sequence *)
   for position := 1 to shiftright do begin
      write(map,' mm ');
   end;

   (* shift the sequence to the right according to the user request *)
   for position := 1 to 2*shiftsequence do begin
      write(map,' mm ');
   end;

   for position := first to last do begin
      (* shift to the right by 1 base or two spaces *)
      (* if the last mark was not a skip to next piece signal, then go on *)
      if not waitfornextpiece then begin
         markup(map,
             charwidth2m,
             cmperbit,
             inttopie(position, pie), (* matching has to be on external
                user defined position, even though that could be ambiguous
                with complex advanced numbering systems. *)
             marks, (* file of mark information *)
             marksymbol,marktype,
             markbase1,markbits1,markbase2,markbits2,
             markscale,nextmark,waitfornextpiece, marksorder);
         write(map,' m2 '); (* go 2 steps per base *)
         if (position mod 15 = 0) then writeln(map);
      end;
   end;
   writeln(map,'grestore');
end;
(* end module writemarks *)

(* begin module isnamestring *)
function isnamestring(n: name; s: string): boolean;
(* is the delila-type name n the same as the string s? *)
var
   c: integer; (* index to n and s *)
   done: boolean; (* done checking *)
begin
(*
write(output,'isnamestring s(',s.length:1,'):');
writestring(output,s);
write(output,', n(',n.length:1,'):');
for c := 1 to n.length do write(output,n.letters[c]);
writeln(output);
*)
   if n.length = s.length then begin
      c := 1;
      done := false;
      while not done do begin
(*
writeln(output,'   ',s.letters[c],' ' ,n.letters[c]);
*)
         if s.letters[c] = n.letters[c]
         then begin
           c := succ(c);
           if c > s.length then begin
              isnamestring := true;
              done := true
           end
         end
         else begin
            isnamestring := false;
            done := true
         end
      end
   end
   else isnamestring := false;
end;
(* end module isnamestring version = 7.70; {of delmod.p 2005 Sep 15} *)

(* begin module writethefeatures *)
procedure writethefeatures(var afile, map: text; mapcontrol: boolean;
                           var linenumber: integer;
                               pie: pieceptr;
                               featurelist: featuretypeptr;
                               first, last: integer;
                               featuresOnSameLine: boolean;
                               featuresOnePerLine: boolean);
(* Write the features from featurelist between (inclusive) position first and
last onto a single line.  One blank is placed between each pair of bases.
If featuresOnSameLine is true, features that continue from one line
to the next remember which line they were on previously.
Otherwise features are packed upward.
If featuresOnePerLine is true, only one feature is put on a line.
The basic approach of the procedure is to do all calculations in bases as real
numbers.  Thus 2.5 is a valid position that indicates a phosphate between bases
2 and 3.  There are then several routines for handling the data line.  One
clears it (clearline), one writes it out (writetheline) and only one is used to
put data into it (fillline).  If mapcontrol is true, write
the features out to the map.

The logic of this routine is to scan through the feature list and note
into 'linetype' arrays what features go where.  This is necessary
because features can come in any order in the list, but they must be
printed strictly left-to-right at least in the ASCII list file.

-----

2001 Jan 4 Bug:
This routine produces lines of features.  Conversion to pdf by gs (ghostscript,
https://alum.mit.edu/www/toms/postscript.html) fails when there
are many spaces.  The message is:

| The font 'Courier-Bold~b0a' contains a bad /BBox

BBox: Postscript manual, second ed, page 174:
bounding box!  So it fails because the bounding
box collapses.
page 202: Entries in a pattern dictionary:
"An array of four numbers in the pattern cell coordinate system, giving
lower-left x, lower-left y, upper-right x, and upper right y of the pattern
cell bounding box.  This bounding box is used to clip the pattern cell and to
determine its size for caching"

This is the postscript that causes the problem:

% writethefeatures
(                                                                                    [----------------------------- ... fes) s n
(                                                      \(-\(-\(-\(-----------\)-\)-\)-\)
U00096.helix[612023.612038]-4.3) s n
(  ) s n


The long space set is apparently the difficulty.  Somehow it gets cached
and recorded in the wrong size, possibly by ps2pdf.  ps2pdf uses ghostscript:

echo "quit" | gs -q -r2000x2000 -sDEVICE=pdfwrite -sOutputFile=$name.pdf $name.ps

In routine writetheline, I added the integer blankcount to count blanks.
When a non-blank is found, all previous blanks are printed using
a postscript function, multiblank, MB.

*)
const
   debuggingShowdata = true; (* show data lines showrecordeddata *)
var
   barger: integer; (* number of features that tried to have priority
      to print on a line.  It should either be 0 or 1.  Larger values
      should be impossible because only one feature can terminate at
      the end of a line (with ellipsis).  If the program finds more than
      one, it is a program error. *)
   printsomefeatures: boolean; (* some features need to be printed *)
   oneunsatisfied: boolean; (* one feature was not satisfied because it
      needed to be but was not printed on this sequence interval *)
   cooleft:  real; (* left edge of the feature in the sequence *)
   cooright: real; (* right edge of the feature in the sequence *)
   coozero: real; (* the internal piece coordinate of zero base *)
   cooway: integer; (* the way to read the Ribl matrix depends on the
      orientation of the feature relative to the coordinate system AND on the
      orientation of the piece relative to the coordinate system. *)
   f: featuretypeptr; (* current place in the featurelist *)
   fbarger: featuretypeptr; (* the previous place on the feature list.
      This is tracked to see if two features claim the same line. *)
   firstedge: real; (* left edge of line, first - 0.5 *)
   lastedge: real; (* right edge of line, last + 0.5 *)
   leftedgeout: boolean; (* the  left edge of the feature is on the line,
                          so we don't write the ellipsis *)
   line: linetype; (* the output line *)
   handling: linetype; (* how to handle writing the line:
      If the character is:
        'n': normal character, write out in black
        't': transparent character, write out in color of letter itself
        'w': walker character, write out as twice wide and height
             determined by height array
        'hrHR': color ascii mode based on Tparam
      *)
   height: array[1..linemax] of real; (* how to write walker characters *)
   angle: array[1..linemax] of integer; (* angle to write walker characters *)
   redgreen: linetype; (* where to write red or green bars on the line *)
   purpleblack: linetype; (* where to write purple or black half bars
                             on the line *)

   phasereverse: integer; (* reverse the wave phase if the angle is -90 *)

   featurehere: array[1..linemax] of featuretypeptr; (* the feature
      responsible for each character on the line *)
{qqq probably this should be generalized to ANY feature}
   walkerposition: array[1..linemax] of integer; (* the relative coordinate
      of this spot in the walker *)
   artmodeline: array[1..linemax] of char; (* whether or not
      to write the characters in the line variable *)
   featurelinenumber: integer; (* the number of the line we are printing *)
   ribl: real; (* the current ri(b,l) matrix value *)
   rightedgeout: boolean; (* the right edge of the feature is on the line,
     so we write out the string otherwise write the ellipsis *)
   spot: real; (* the spot where a mark is written into the line *)
{
   atzero: boolean; (* true when coozero = spot - used for verticalline *)
}
procedure clearlines;
(* complete clear of the lines for safety.
This does not clear the verticalmemory since that runs
across multiple lines. *)
var
   i: integer; (* index *)
begin
   for i := 1 to actualmax do line[i] := ' ';
   if mapcontrol then begin
      for i := 1 to actualmax do begin
         handling[i] := 'n';
         height[i] := 0.0;
         redgreen[i] := ' ';
         purpleblack[i] := ' ';
         angle[i] := 0;
         featurehere[i] := nil;
         walkerposition[i] := 0;
         artmodeline[i] := ' '; (* default to write the characters *)
      end;
   end;
   actualmax := 0;
end;

procedure showline;
(* show the line array without any side effects *)
var lineplace: integer;
begin (* showline *)
   for lineplace := 1 to actualmax
   do if ord(line[lineplace]) = tabcharacter
      then write(afile,' ')
      else write(afile,line[lineplace]);
   writeln(afile);
end; (* showline *)

procedure writetheline;
(* write the line *)
const
   backslash = '\'; (* the backslash character *)
   tabcharacter = 9; (* the ordinal of the tab character *)
var
   c: char; (* a character write out *)
   blankcount: integer; (* current number of blanks stored up *)
   doingwalker: boolean; (* are we doing any walkers on this line? *)
   drawinglines: boolean; (* are we drawing lines across the page as a
      request from any walker? *)
   i: integer; (* index *)
   shutup: boolean; (* limit the yelling *)

procedure spitoutblanks(var afile: text; var blankcount: integer);
(* spit out the blanks saved up in variable blankcount *)
begin
{nnn}
{
writeln(afile, ') %', blankcount:1);
write(afile, '( % spitoutblanks: ', blankcount:1);
}
   if blankcount > 0
   then begin
      (*  the ') s' closes and write any previous material *)
      writeln(afile,') s ',blankcount:1, ' MB');
      write(afile,'('); (* start the continuing string on the next line *)
      blankcount := 0;
   end;
end;

procedure writecharacter(var afile: text; c: char);
(* write the character c to afile.  If it is a space, count it.
If there were stored spaces, spit them all out at once
by calling the multiblank routine, mb. *)
begin

   (* store up blanks and spit them out with a call to the MB routine: *)
   if c = ' '
   then blankcount := succ(blankcount)
   else begin
      spitoutblanks(afile, blankcount);
{
nnn
      if blankcount > 0
      then begin
         (*  the ') s' closes and write any previous material *)
         writeln(afile,') s ',blankcount:1, ' MB');
         write(afile,'('); (* start the continuing string on the next line *)
         blankcount := 0;
      end;
}

{
      (* this was the original code: *)
      protectpostscript(afile, c);
      write(afile,c);
}
      (* three characters need special treatment
         to avoid the font compression bug *)

      if c in ['(',')','-'] then begin
         write(afile,') s gsave (');
         protectpostscript(afile, c);
{uuu the other point of writing the character:
         write(afile,'@'); (* use this to demonstrate dashes *)
}
         write(afile,c);
         writeln(afile,') s grestore');
         write(afile,'( '); (* that space does the actual shift! *)
      end
      else begin
         protectpostscript(afile, c);
{uuu the point of writing the character:
         write(afile,'!'); (* use this to demonstrate characters *)
}
         write(afile,c);
      end

   end;
end; (* writecharacter *)

procedure dobackslash;
(* handle backslashes for feature names.  If the character c
is protected, just write it.  Otherwise use writecharacter
to handle blanks.  The afile corresponds to the list file. *)
begin
   if (artmode = 'a') or (artmode = 'b') or (artmode = 'B')
   then c := ' '
   else if artmode = 'n'
        then begin
{
write(output,'IS HERE i=',i:1);
writeln(output,' artmodeline[i] ="',artmodeline[i]:1,'"');
}
  if artmodeline[i] = ' ' then c := ' ';
end;
{
        then if artmodeline[i] = ' ' then c := ' ';
   if artmodeline[i] <> ' ' then c := ' ';
}

   if line[i] <> backslash then begin
      if i > 1
      then if line[i-1] = backslash
           then write(map,c)
           else begin
              writecharacter(map,c);
              write(afile,c);
           end
      else begin
              writecharacter(map,c);
              write(afile,c);
           end
   end
   else begin (* the character is a '\\' *)
      if i > 1
      then if line[i-1] = backslash
           then write(map,c) (* this is a '\\' *)
   end
end; (* dobackslash *)

procedure docolorbar;
(* make a colored bar if appropriate *)
const
   debugging = false; (* set true when debugging *)
   spectrum = false; (* set to true to make spectrum on the gap bar
                        for debugging or fun.  This replaces the linear
                        interpolated color bar with a red-to-red spectrum. *)
var
   hue, saturation, brightness: real; (* the color *)
   hue1, hue2: real; (* two hues at the ends of the feature *)
   saturation1, saturation2: real; (* two saturations at the ends of
      the feature *)
   brightness1, brightness2: real; (* two brightnesess at the ends of
      the feature *)
begin
   (* 2005 Aug 4: If, for whatever reason, there are no
      others, do not do the color bar.  The reason that I know
      about is a case where there is a two part site
      consisting of the same kind.  One of them loses the
      other component for unknown reasons *)
   if featurehere[i] <> nil
   then if featurehere[i]^.others <> nil then begin

      if featurehere[i]^.definition^.isgap then begin
         if featurehere[i] = horizontalmemory[i].feature
         then begin (* this feature has been marked to have a color bar *)
            if featurehere[i]^.definition^.marks <> 0 then begin
               spitoutblanks(map, blankcount);
               writeln(map, ') s'); (* complete previous string *)

               (* a lovely default is the memory, which gives a spectrum! *)
               hue := horizontalmemory[i].state; (* DEFAULT! *)
               saturation := 1.0;

               (* We need to look up the two features at the ends of
               this one.  Then we compute the hue and brightness
               between them.  Saturation is full (1.0). *)

               (* We go through this feature to the ones it points to.
               Then through the definitions into the petaltype to get
               the hue and saturations.  Gap features have exactly
               two ends and we do the fade between them. *)

               if (featurehere[i]^.others^.next = nil)
               then begin (* new safety check 2006 Oct 10: *)
                  (* the other part is missing!!! *)
                  writeln(output,'*******************************************');
                  writeln(output,'* Gap feature is missing second part! *****');
                  writeln(output,'* ');
                  writeafeature(output,featurehere[i]);
                  writeln(output);
                  writeln(output,'* ');
                  showafeature(output,featurehere[i]);
                  writeln(output,'*******************************************');
                  halt;
               end;

               if (featurehere[i]^.others^.next^.next <> nil)
                  and (not shutup)
               then begin
                  (* safety check: *)
                  writeln(output,'*******************************************');
                  writeln(output,'* WARNING!!! docolorbar: Gap feature: *****');
                  write  (output,'* ');
                  writeafeature(output,featurehere[i]);
                  writeln(output);
                  writeln(output,'* has more than one "OTHER" feature!      *');
                  showafeature(output,featurehere[i]);
                  writeln(output,'*******************************************');
                  shutup := true;
                  {2005 Sep 27: This is because the end is picking
                  based on the location but it needs also to pick
                  based on the NAME of the thing!  Example is sigma70
                  of flhD around 1976460 - a p10 has the same
                  coordinate of a p35.}
               end;

               (* make a colored bar at coordinate i for this feature *)
               with featurehere[i]^.others^ do begin
                  (* determine colors on the ends of the bar: *)
                  (* 2016 Aug 29 reverse the colors *)

                  hue1 :=
                   computeacolor(next^.afeature,
                                 next^.afeature^.definition^.petal.fh);

                  hue2 :=
                   computeacolor(      afeature,
                                       afeature^.definition^.petal.fh);

                  saturation1 :=
                   computeacolor(next^.afeature,
                                 next^.afeature^.definition^.petal.fs);

                  saturation2 :=
                   computeacolor(      afeature,
                                       afeature^.definition^.petal.fs);

                  brightness1 :=
                      computeacolor(next^.afeature,
                                    next^.afeature^.definition^.petal.fb);

                  brightness2 :=
                      computeacolor(      afeature,
                                          afeature^.definition^.petal.fb);

                  (* BAR REVERSAL *)
                  (* Determine if the bar direction should be switched: *)
                  (* 2007 Mar 13.  It's not absolutely clear that this
                     logic covers the cases fully.  For example, if
                     one of the sites is symmetric, then it may
                     fail.  Note that it only checks afeature and
                     not next^.afeature.  It may be necessary to
                     check both.  The code was tested on sigma70 sites
                     of both orientations on a piece and its complement:
                        title "fadD";
                        organism E.coli-K12;
                        chromosome E.coli-K12;
                        piece NC_000913;
                        get from 1886666 +20 to 1886636 -20 dir -;
                        get from 1886636 -20 to 1886666 +20 dir +;
                   *)
                  if
                    (
                     (afeature^.orientation = -1)
                     and
                     (pie^.key.piedir =  pie^.key.coodir)
                    )
                  or
                    (
                     (afeature^.orientation = +1)
                     and
                     (pie^.key.piedir <> pie^.key.coodir)
                    )
                  then begin
                     (* switch the colors *)
                     hue  := hue1;
                     hue1 := hue2;
                     hue2 := hue;
                     saturation  := saturation1;
                     saturation1 := saturation2;
                     saturation2 := saturation;
                     brightness  := brightness1;
                     brightness1 := brightness2;
                     brightness2 := brightness;
                  end;

                  (* Do a linear interpolation between the colors: *)
                  hue :=
                     hue1 * (    horizontalmemory[i].state)
                     +
                     hue2 * (1 - horizontalmemory[i].state);

                  saturation :=
                     saturation1 * (    horizontalmemory[i].state)
                     +
                     saturation2 * (1 - horizontalmemory[i].state);

                  brightness :=
                     brightness1 * (    horizontalmemory[i].state)
                     +
                     brightness2 * (1 - horizontalmemory[i].state);

               end;

               (* For debugging or fun: create a spectrum across the bar
                  instead of the usual interpolated colors. *)
               if spectrum then begin
                  hue := horizontalmemory[i].state;
                  saturation := 1.0;
                  brightness := 1.0;
               end;

               (* brightness = 0 means that there are no petal colors *)
               if (brightness > 0) and dohorizontal then begin
                  writeln(map,
                  ' ', hue:pwid:pdec,
                  ' ', saturation:pwid:pdec,
                  ' ', brightness:pwid:pdec, ' sethsbcolor');
                  writeln(map,'% docolorbar'); {HHH}
                  write(map, '( ) ',
                      horizontalbarwidth:pwid:pdec, (* width of the bar *)
                      horizontalbarheight:pwid:pdec, (* height of the bar *)
                      ' letterrectangle (');
               end
               else write(map, '(');

            end;
         end
      end;
      if featurehere[i]^.definition^.ismulti then begin
               spitoutblanks(map, blankcount);
               writeln(map, ') s'); (* complete previous string *)

               (* for debugging: create a spectrum across the bar *)
               if spectrum then begin
                  hue := horizontalmemory[i].state;
                  hue := 0.5;
                  saturation := 1.0;
                  brightness := 1.0;
               end;

               (* 2006 Oct 20.  There were extra calls to letterrectangle
                  for the total lines.
                  Setting saturation to zero neutralizes the remaining
                  code, removing the unnecessary calls.
                  That is, saturation was zero, which makes the
                  letterrectangles invisible.  So there is no
                  reason to do the call!
                  This might be a mistake, but i don't know exactly
                  what the code here was to do!
                  So maybe some day this has to be fixed.
               *)

               hue := 0.5;
               saturation := 0.0;
               brightness := 1.0;
{
writeln(output, 'featurehere[i]^.Tparam = ', featurehere[i]^.Tparam:1);
writeln(output, 'featurehere[i]^.Aparam = ', featurehere[i]^.Aparam:1:1);
writeln(output, 'featurehere[i]^.Bparam = ', featurehere[i]^.Bparam:1:1);
writeln(output, 'featurehere[i]^.Cparam = ', featurehere[i]^.Cparam:1:1);
writeln(output, 'featurehere[i]^.Dparam = ', featurehere[i]^.Dparam:1:1);
}
               with featurehere[i]^ do begin
                  brightness := (Bparam - Aparam)/ (Cparam - Aparam);
               end;

               if (brightness > 0) and (saturation > 0) then begin
                  writeln(map,
                  ' ', hue:pwid:pdec,
                  ' ', saturation:pwid:pdec,
                  ' ', brightness:pwid:pdec, ' sethsbcolor');
                  write(map, '( ) ',
                      1.0:pwid:pdec, (* width of the bar *)
                      0.1:pwid:pdec, (* height of the bar *)
                      ' letterrectangle (');
               end
               else write(map, '(');

      end;
   end;
end; (* docolorbar *)

procedure doletterrectangle;
(* make a rectangle the size of a letter to the map *)
var
   petalchar: char; (* the character passed to letterrectangle.
      instead of c, which is the current character.  Only '<'
      and '>' are passed, other characters are sent as ' '.
      This makes writing the postscript simple.
      Otherwise I'd have to implement all that complex stuff
      in dobackslash to make sure the character doesn't
      wreck the PostScript! *)
begin
   spitoutblanks(map, blankcount);
   write(map,') s ');
   if c in ['<','>']
   then petalchar := c
   else petalchar := ' ';
   write(map, '(',petalchar,')',
      1.0:pwid:pdec, (* width of the bar *)
      featurehere[i]^.Dparam:pwid:pdec, (* height of the bar *)
      ' letterrectangle (');
   dobackslash; (* put the character over the rectangle *)
end; (* doletterrectangle *)

procedure writeonecolor(var afile: text;
                        cr: petaltype;
                        colorvalue: real);
(* write a color value colorvalue to afile petal information.
If the colorvalue is less than zero, replace it with
Ri*abs(colorvalue)/consensus when Ri > 0 and 0 when Ri < 0.  If
Ri*abs(colorvalue/consensus) is greater than 1, only print 1.0 *)
const debugging = false;
begin
   write(afile, ' ',computeacolor(featurehere[i],colorvalue):pwid:pdec);
end;

procedure writecolorbase(var afile: text; cr: petaltype);
(* write the petal information *)
begin
   with cr do begin
      write(afile, el:1);
      write(afile, ' (',c,') ');
      writeonecolor(afile, cr, eh);
      writeonecolor(afile, cr, es);
      writeonecolor(afile, cr, eb);
      writeonecolor(afile, cr, fh);
      writeonecolor(afile, cr, fs);
      writeonecolor(afile, cr, fb);
      writeonecolor(afile, cr, spare);
   end;
end;

procedure drawpetal;
(* draw a colored rectangle behind the sequence walker *)
begin
   if featurehere[i]^.definition^.petal.c <> ' ' then begin
      if walkerposition[i] = featurehere[i]^.fromrange
      then begin
         writecolorbase(map,featurehere[i]^.definition^.petal);
         writeln(map,' 1 0 1 1 makerectangle')
      end
      else if walkerposition[i] = featurehere[i]^.torange
      then begin
         writecolorbase(map,featurehere[i]^.definition^.petal);
         writeln(map,' 0 1 1 1 makerectangle')
      end
      else begin
         writecolorbase(map,featurehere[i]^.definition^.petal);
         writeln(map,' 0 0 1 1 makerectangle');
      end;
   end;
end;

procedure setcolors(i: integer);
(* set the colors according to Tparam for the feature
at line position i
The form is:
    ') s 0 0 1 setrgbcolor ('
The starting ')' closes the previous string
while the '(' opens the next one. *)
var
   t: char; (* The Tparam for this feature *)
begin
   t := featurehere[i]^.Tparam;
   if t in ['h','r','H','R'] then begin
      write(map,') s ',
                featurehere[i]^.Aparam:pwid:pdec,
                featurehere[i]^.Bparam:pwid:pdec,
                featurehere[i]^.Cparam:pwid:pdec);
      case t of
         'h','H': writeln(map,' sethsbcolor');
         'r','R': writeln(map,' setrgbcolor');
      end;
      write(map,'(');
   end;
end;

procedure resetcolors;
(* reset the color to black *)
begin
   writeln(map,') s 0 setgray'); write(map,'(');
end;

procedure showrecordeddata(var afile: text);
(* important debugging tools:  show the recorded lines: *)
var
   i: integer; (* index to lines *)
   c: char; (* a character to display *)
begin

   writeln(output);

   (* the data line *)
   for i := 1 to actualmax do begin
      c := line[i];
      if ord(c) = tabcharacter then c := ' '; (* tab converted to blank *)
      write(output,c);
   end;
   writeln(output, ' line[i]');

   (* the handling line *)
   for i := 1 to actualmax do begin
      c := handling[i];
      write(output,c);
   end;
   writeln(output, ' handling[i]');

   (* the featurehere interpretation line *)
   for i := 1 to actualmax do begin
      if featurehere[i] <> nil
      then begin
        if featurehere[i]^.definition^.ismulti
        then if horizontalmemory[i].feature <> nil
             then c := 'H'
             else c := '#'
        else c := '^'
      end
      else c := '_';
      write(output,c);
   end;
   writeln(output, ' featurehere[i]');
   writefeaturememory(output,horizontalmemory);
   writeln(output, ' horizontalmemory[i]');

   (* the verticalmemory line *)
   writefeaturememory(output,verticalmemory);
   writeln(output,' verticalmemory[i] vmmax =',vmmax:1);
end; (* showrecordeddata *)

begin (* writethefeatures probably should be called writetheline? *)
   shutup := false;

   (* trim blanks off end of line *)
   (* the if will protect the while loop from cases where actualmax = 0: *)
   if actualmax > 2
   then while (actualmax > 2) and
         ((line[actualmax]=chr(tabcharacter)) or
          (line[actualmax]=' '))
   do begin
      (* force it to be a blank so that clearlines
         functions properly *)
      line[actualmax] := ' ';
      actualmax := pred(actualmax);
   end;

   if mapcontrol then begin
      doingwalker := false;
      drawinglines := false;
      i := 1;
      while i <= actualmax do begin
         if handling[i] in ['w', 'W','l','L','i','I']
         then begin
            doingwalker := true;
            if handling[i] in ['l','L'] then drawinglines := true;
         end;
         i := succ(i)
      end;

      (* displace one "bit" downward for walker display *)
{zwzwzw
Should the walker really define
the line to be thicker?  This prevents one from putting
character type features at any line except the walker zero line.
2004 July 28: This interferes with vertical bars.  vvv
              Somehow it should be eliminated!
2004 July 29: One way is to have nextline write the vertical bars.
}
      if doingwalker
      then nextline(afile,map,mapcontrol,false,
                    linenumber,pagenumber,basesperline, blankcount,
                    line);

      if drawinglines then writeln(map,'pagecharacters hlines');

      doshift;
      write(map,'('); (* this starts the PostScript line *)
   end;

   blankcount := 0;

if superdebug then begin
   if debuggingShowdata then showrecordeddata(output);
end;
{vvv}

   (* insert vertical memory characters here? *)
   shutup := false;
{ggg}
   for i := 1 to actualmax do begin
      c := line[i];
      if ord(c) = tabcharacter then c := ' '; (* tab converted to blank *)
         docolorbar;

{vvv}
{ USE THIS TO MARK THE VERTICAL MEMORY ON THE MAP
if verticalmemory[i].state > 0 then begin
 case round(verticalmemory[i].state) of
  -1: c := '-';
   0: c := '0';
   1: c := '1';
   2: c := '2';
 end;
end;
}

      if mapcontrol then begin
         case handling[i] of

            'n': begin (* normal character *)
                 docolorbar;
                 dobackslash;
            end;
            'h','H','r','R': begin (* colored character *)
{
write  (output,'at colored character, i = ',i:1);
write  (output,' linenumber =',linenumber:1);
write  (output,' handling[i] = ',handling[i]:1);
if featurehere[i] = nil
then write(output,' featurehere[i] = nil')
else write(output,' featurehere[i] = nil NOT');
writeln(output);
}
                 if featurehere[i] = nil
                 then dobackslash
                 else begin

{
writeln(output,'says: featurehere[',i:1,']^.Tparam = ',
featurehere[i]^.Tparam);
writeln(output,'happy');
}
                    (* color control of the bar *)
                    (* dobackslash calls writecharacter.
                       writecharacter does the actual writing *)
                    (* The featurehere array tells us the way to color
                       the character of the feature here. *)
                    if (featurehere[i]^.Tparam = ' ') or
                       (featurehere[i]^.Tparam = 'n')
                    then begin
                       dobackslash;
                    end
                    else begin
                       setcolors(i);
                       case featurehere[i]^.Tparam of
                        'h','r': begin
                                    dobackslash;
                                    resetcolors;
                                 end;
                        'H','R': begin
                                    doletterrectangle;
                                    (* resetcolors; is done in
                                       letterrectangle *)
                                 end;
                       end;
                    end
                 end
            end;
            't': begin (* transparent *)
               if c in ['a','c','g','t']
               then begin (* only colored bases can be done this way *)
                  write(map,'Z');
                  write(map,') s ');
                  protectpostscript(map, c);
                  write(map,c,' b (');
               end
               else begin (* handle other characters normally *)

                  dobackslash;

               end;
            end;
            'w','W','l','L','i','I': begin (* walker *)
               if c in ['a','c','g','t']
               then begin (* only colored bases can be done this way *)

                  (* we had better spit out any spaces that are stored up! *)
                  writeln(map,') s ',blankcount:1, ' MB');
                  blankcount := 0;

                  (* maybe make a red or green bar
                     at the zero coordinate of a sequence walker *)
                  if redgreen[i] in ['r','g'] then begin
                     case redgreen[i] of
                         'r': write(map,'pink');
                         'g': write(map,'greenish');
                         ' ': begin
                                 writeln(output,'redgreen error!');
                                 halt
                              end;
                     end;
                     writeln(map,' makebar');
                     if featurehere[i]^.mothers <> nil
                        (* We are at the zero coordinate of a feature
                           so start the vertical memory for this walker
                           if it is part of a multi-walker structure *)
                     then begin

if superdebug then begin
  writeln(output, 'Feature:');
  writeafeature(output, featurehere[i]); writeln(output);
  writeln(output, 'HAS a mother and she is');
  writeafeature(output, featurehere[i]^.mothers^.afeature); writeln(output);
end;
if superdebug then begin
writeln(output);
writeln(output,'BEFORE WALKER feature verticalmemory stepvm',
               ' linenumber = ', linenumber:2 );
writefeaturememory(output,verticalmemory); writeln(output);
end;

                        (* set the vertical memory for a walker feature *)
{2016Aug31 this is THE call to stepvm:}
                        stepvm(featurehere[i],i,featurehere[i]^.coordinate); (* step for features *)

{yyy}
if superdebug then begin
writeln(output,'AFTER  WALKER feature verticalmemory stepvm',
               ' linenumber = ', linenumber:2 );
writefeaturememory(output,verticalmemory); writeln(output);
end;

                     end
                     else begin

if superdebug then begin
  writeln(output, 'Feature:');
  writeafeature(output, featurehere[i]); writeln(output);
  writeln(output, 'has no mother');
end;

                     end;

                  end
                  else begin
                     (* 2004 jul 13: draw a rectangle around the
                        letter space *)
                     drawpetal;
                  end;

                  (* maybe make a purple or black bar on top of any previous
                     bar *)
                  if purpleblack[i] in ['p','b'] then begin
                     case purpleblack[i] of
                         'p': write(map,'downpurple');
                         'b': write(map,'downblack');
                     end;
                     writeln(map,' makedownbar');
                  end;

                  if handling[i] in ['W','L','I'] then begin
                     if not showingbox then begin
                        writeln(map,'/showingbox true def');
                        showingbox := true;
                     end
                  end
                  else begin (* handling[i] in ['w','l','i'] *)
                     if showingbox then begin
                        writeln(map,'/showingbox false def');
                        showingbox := false;
                     end;
                  end;

                  if height[i] < figurebottom
                  then begin
                     writeln(map, 'gsave');
                     writeln(map, 'clipdown');
                  end;

                  write(map, height[i]:pwid:pdec,' (');

                  (* write the walker character out: *)
                  protectpostscript(map, c);
                  writeln(map,c,') ',angle[i]:1,' wc');

                  (* writeln(output,'angle[',i:1,']=',angle[i]:1); *)
                  if angle[i] = -90
                  then phasereverse := -1
                  else phasereverse := +1;

                  if height[i] < figurebottom
                  then begin
                     (* Clipping means we must gsave and grestore.
                        But this blocks stepping.
                        The '( ) s' ensures that we move to the right *)
                     writeln(map, 'grestore ( ) s');
                  end;

                  (* write the wave over the character *)
                  writeln(map,'gsave ');
                  (* put coordinate system at the walker: *)
                  writeln(map,'currentpoint translate');
                  (* shift half character over to match walker letters: *)
                  writeln(map,'charwidth2d 0 translate');
                  writeln(map,'0 setgray'); (* all black *)
                  docosinewave(map,
                    featurehere[i]^.definition^.matrix^.waves,
                    (* twice the character width, like walker *)
                    charwidth2m, (* fudge factor *)
                    cmperbit, (* cm per bit *)
                    2*cmperbit,(* barheight, character height in cm *)
                    1, (* stacknumber, just default to 1 *)
                    walkerposition[i], (* position in site *)
                    phasereverse); (* walker direction *)
                  writeln(map,'grestore');

                  write(map,' b (');

                  (* write the walker character to the list file *)
                  write(afile,c);
               end
               else begin (* handle other characters normally *)
                  dobackslash;
               end;

               if handling[i] in ['i','I'] then begin
                  (* draw lines across the walker *)
                  writeln(map,') s');
                  writeln(map,'-1 hlines');
                  write(map,'(');
               end;
            end;
         end;
      end;

   end;

   if mapcontrol then begin
      write(map,') s');
      if doingwalker then begin
         for i := 1 to -figurebottom
         do nextline(afile,map,mapcontrol,false,
                     linenumber,pagenumber,basesperline, blankcount,
                     line);
      end;
   end;

   (* writeln(afile); is done by nextline *)
   nextline(afile,map,mapcontrol,true,
            linenumber,pagenumber,basesperline, blankcount,
            line);
   featurelinenumber := succ(featurelinenumber)
end; (* writetheline *)

procedure linefunction(spot: real;
                   var location: integer;
                   var inside: boolean);
(* Convert the base position spot to the line location.
"spot" is in bases on the sequence, this is converted to
characters on the line by subtracting the first base of the line.
Adding 1 makes it positive.  Then we multiply by 2 to get characters,
since there are two characters per base in lister displays.
Then we shift right by a constant.  If the location was
inside the line, "inside" is returned true. *)
begin
   location := round(2.0 * (spot-first+1)) + shiftright;
   if location < 1 then begin
      writeln(output,'error in linefunction');
      writeln(output,'---error in linefunction:');
      writeln(output,'   spot=',spot:1:1);
      writeln(output,'   first=',first:1);
      writeln(output,'   last=',last:1);
      writeln(output,'   shiftright=',shiftright:1);
      writeln(output,'   location=',location:1);
      inside := false;
   end;
   if location > linemax then begin
      writeln(output,'A character location is ',location:1);
      writeln(output,'but the line maximum (linemax) is ',linemax:1);
      writeln(output,'Increase constant linemax to avoid truncated lines.');
      inside := false;
   end
   else inside := true;
end; (* linefunction *)

function openspace(lowerspot, upperspot: real): boolean;
(* determine if there are any marks in the range lowerspot through
upperspot.  If there are spots, return false otherwise return true. *)
var
   l, u: integer; (* lower and upper positions on the line *)
   linside, uinside: boolean; (* l and u are inside the printable line? *)
   hold: integer; (* temporary storage for swapping l and u *)
   p: integer; (* a position the line *)
   nostuff: boolean; (* true if there is a blank character in the line *)
begin
   (* Alter lowerspot and upperspot locally (ie only within
      this function) to make sure we do not go outside the line
      we are printing on.  This prevents linefunction from
      putting out warnings (unless there is a program error). *)

   if lowerspot < first then lowerspot := first - 0.5;
   if upperspot < first then upperspot := first - 0.5;
   if lowerspot > last  then lowerspot := last  + 0.5;
   if upperspot > last  then upperspot := last  + 0.5;

   linefunction(lowerspot,l,linside);
   linefunction(upperspot,u,uinside);

if intensedebug then begin
writeln(list,'first:',first:pwid);
writeln(list,'last:',last:pwid);
writeln(list,'upperspot:',upperspot:pwid:pdec);
writeln(list,'lowerspot:',lowerspot:pwid:pdec);
write  (list,'l:',l:pwid);
writeln(list,'  linside:',linside);
writeln(list,'u:',u:pwid);
write  (list,'  uinside:',uinside);
end;

   (* make sure these are in ascending order: *)
   if l > u then begin
      hold := u;
      u := l;
      l := hold
   end;

   if not linside then begin
      if l < 1 then l := 1;
      if l > linemax then l := linemax;
   end;

   if not uinside then begin
      if u < 1 then u := 1;
      if u > linemax then u := linemax;
   end;

   nostuff := true;
   p := l;
   while nostuff and (p <= u) do begin
      if line[p] <> ' ' then nostuff := false;
      p := succ(p);
   end;
if debug then writeln(list,'openspace test gives: ',nostuff);
   openspace := nostuff
end; (* openspace *)

procedure fillline(spot: real; c: char);
(* fill the line with character c at the given base coordinate spot.
If the character is blank, don't do anything.  This makes
this character "transparent" so they reveal the background.
In contrast, a tab character is treated as a solid object, and
will be written to the spot. *)
var
   lineplace: integer; (* place to put c on the line *)
   inside: boolean; (* is c inside the line? *)
begin (* fillline *)
   if c <> ' ' then begin
      linefunction(spot, lineplace, inside);
      if antiartmode then artmodeline[lineplace] := '-';
{HHH horizontalbarcharacter?}
      if inside then begin
         line[lineplace] := c;
{
writeln(list,'line[lineplace] := c;',
             'line[',lineplace,'] := ',c,';');
}
         if actualmax < lineplace then actualmax := lineplace
      end
      else begin
         writeln(output,'fillline: character "',c,
                        '" outside line range @',lineplace:1,
                        ' was truncated');
         halt
      end
   end;
if intensedebug then showline
end; (* fillline *)

procedure ellipsis(spot: real);
(* put an ellipsis at the given spot in bases *)
var
   i: real; (* index *)
begin
{
writeln(afile,'ellipsis spot: ',spot:1:1);
}
   i := 0.0;
   while i <= 1.0 do begin
      fillline(i+spot, '.');
      i := i + 0.5;
   end;
end; (* ellipsis *)

procedure putstring(n: string; fromstring: real);
(* put the string n starting at base coordinate fromstring in the line *)
var
   tostring: real; (* right edge of the string on the line *)
   spot: real; (* the spot where a mark is written into the line *)
begin
   (* Where to end the string?  We have to divide n.length by 2 because we are
      still working in base space.  If the string were exactly 1 character
      long, it should end at fromstring.  So set n.length = 1 and n.length/2.0
      is 0.5.  This 0.5 must be removed. *)
{
write(afile,'putstring........................');
writequotestring(afile,n);
writeln(afile);
writeln(list,'z=',z:1);
writeln(list,'fromstring=',fromstring:pwid:pdec);
}
   tostring := fromstring + n.length/2.0 - 0.5;
   spot := fromstring;
{
showline;
}
   while spot <= tostring do begin
      fillline(spot,n.letters[round(2*(spot-fromstring))+1]);
{
showline;
}
      spot := spot + 0.5;
   end;
{
writeln(afile,'............................................');
}
end;

(* __________________________________________________________________________ *)

procedure report(var afile: text; f: featuretypeptr);
(* report the feature on one line for debugging *)
begin
   with f^ do begin
{
}
      write(afile,' unsatisfied: ',unsatisfied,' ');
      (* 'true' is one character shorter than 'false', even them up: *)
      if unsatisfied then write(afile,' ');

      write(afile,' DesiredLine: ',  desiredline:5);
      write(afile,' ');

      writeafeature(afile,f);
      writeln(afile);
   end;
end; (* report *)

procedure printfeature;
(* Print the feature f.  This is done by recording the feature
into a set of arrays.  The actual drawing is done later in
writethefeatures *)
var
   b: base; (* a base to print *)
   c: char; (* b as a character *)
   tabindex: integer; (* index for putting tabs into the line *)
   l: integer; (* the from-to location of b *)
   lineplace: integer; (* place to put character on the line *)
   inside: boolean; (* are we inside the line? *)
   m: integer; (* index to marks of a feature *)
{
   o: featurecarrierptr; (* another feature this feature points to! *)
}
{Ppp}
begin
(* writequotestring(output,f^.nametag);write(output);{QQQ} *)
(* writeln(output,'   printfeature QQQ - never entered by ygaD!!'); *)
if debug then
if f^.unsatisfied then begin write(list,'PRINT:  '); report(list,f); end;
{
}

{
writeln(list,'printfeature --------');
writeln(list,'orientation=',orientation:5:1);
writeln(list,'coozero=',coozero:5:1);
writeln(list,'spot=',spot:5:1);
writeln(list,'matrix^.frombase=',matrix^.frombase:5:1);
(* old:
writeln(list,'1-matrix^.frombase=',1-matrix^.frombase:5:1);
*)
writeln(list,'1-matrix^.frombase=',matrix^.frombase:5:1);
writeln(list,'orientation*(coozero-spot) =',
              orientation*(coozero-spot) :5:1);
writeln(list,'round(orientation*(coozero-spot) )=',
              round(orientation*(coozero-spot) ):5:1);
(*old:
writeln(list,'round(orientation*(coozero-spot) + 1-matrix^.frombase)=',
              round(orientation*(coozero-spot) + 1-matrix^.frombase):5:1);
*)
writeln(list,'round(orientation*(coozero-spot) + matrix^.frombase)=',
              round(orientation*(coozero-spot) + matrix^.frombase):5:1);
}

   (* 2004 Dec 5: the following line caused a crash of the
   GPC compiler:
      with f^, f^.definition^ do begin {causes GPC crash}
   The next line should solve it: *)
   with f^ do with f^.definition^ do begin

(*
writeln(output,'cooleft = ',cooleft:4:1); {hhh}
writeln(output,'cooright = ',cooright:4:1); {hhh}
writeln(output,'last = ',last:4); {hhh}
*)
(* writeln(output,'   cooleft = ',cooleft:4:1); {hhh} {QQQ not even here!} *)
(* writeln(output,'   cooright = ',cooright:4:1); {hhh} {QQQ not even here!} *)
(* writeln(output,'   last = ',last:4); {hhh} {QQQ not even here!} *)

{
report(output,f);
}

      (* lay down the background of the feature *)
      spot := cooleft;
      while spot <= cooright do begin

{hhh}
{
writeln(output,'spot=', spot:3:1);
writeln(output,'spot=', spot:3:1);
write  (list,'spot=', spot:3:1);
write  (list,' round(spot)=', round(spot):1);
write  (list,' trunc(spot)=', trunc(spot):1);
}

         (* add 0.5 to last to get the last half background character *)
{QQQ}
{
write(output,'if between(first,spot,last+0.5) then begin',
' ',first+0.0:5:1,
' ',     spot:5:1,
' ', last+0.5:5:1
);
}

(*
if between(last-0.5,spot,first) then begin
write(output,'!',spot:5:1); {QQQ}  {nothing showed up}
end;
*)
         if between(first,spot,last+0.5) then begin
(*
write(output,'B',spot:5:1); {QQQ} {missing for ygaD}
*)
            linefunction(spot, lineplace, inside);
            if ismulti then begin
               (* record the ascii feature in the horizontal memory
                  so that the color bar can be written behind it *)
               horizontalmemory[lineplace].state :=
                  (spot-cooleft)/(cooright-cooleft);
               horizontalmemory[lineplace].feature := f;
            end;

            (* start and write vertical connectors.  This has to
               be done before the feature so the feature overwrites. *)
            if spot = coozero then begin
               if f^.definition^.ismulti then begin
                  linefunction(spot, lineplace, inside);
               end;
            end;

            (* convert from bases-on-the-line to character coordinates: *)
            case background.length of
            1: begin (* this is a regular ascii feature *)
               (* this is the place that the feature background letter
                  is put into the line *)
               if (f^.Tparam in [' ','n','h','r'])
               then antiartmode := true; (* for artmode *)
               fillline(spot,background.letters[1]);
               (* At this point we can note the feature pointer.
                  in the featurehere array.  This makes the
                  featurehere array now more generalized.
                  The featurehere array can now be used
                  for coloring the ascii letters. *)
                  linefunction(spot, lineplace, inside);
                  if inside then begin
                     featurehere[lineplace] := f;
                     if f^.Tparam <> ' '
                     then handling[lineplace] := f^.Tparam;
                  end;
               antiartmode := false; (* for artmode *)
            end;

            2: begin (* this might be a walker or other things
               depending on the second background character *)
               (* if we are on a whole number base ... *)
               if round(spot) = trunc(spot) then begin
                  linefunction(spot, lineplace, inside);
                  if inside then begin
                     (* get the base from the sequence: *)
                     b := getbase(round(spot),pie);

                     (* Determine the letter to print.  Use the 5' to
                        3' top strand for symmetric sites.  Use the
                        orientation for asymmetric sites. *)
                     if matrix^.symmetry = 'a'
                     then begin (* asymmetric *)
                        (* give the complement if the orientation is
                           opposite the piece *)
                        if cooway = -1
                        then c := basetochar(complement(b))
                        else c := basetochar(b);
                     end
                     else c := basetochar(b); (* e or o symmetric *)
                     fillline(spot, c); (* print the letter *)
{jjj}
{BBB}
                     if cooway = -1 then b := complement(b);
{
if cooway < 0 then write(output,'-')
              else write(output,'+');
write(output,matrix^.symmetry);
}

                     (* determine position in matrix to get the value: *)
                     l := round(cooway*(spot-coozero));

                     if mapcontrol then begin
                        if background.letters[2] = 'd'
                        then handling[lineplace] := 't' (* transparent *)
                        else if background.letters[2]
                                in ['w','W','l','L','i','I']
                        then begin (* implement the walker here! *)
                           handling[lineplace] := background.letters[2];

{uuu}
                           (* record the walker memory *)
                           walkermemory[lineplace  ].feature := f;
                           walkermemory[lineplace  ].state   := 1-lowerbound;
                           walkermemory[lineplace+1].feature := f;
                           walkermemory[lineplace+1].state   := 1-lowerbound;
                           walkermemory[lineplace+1].next    := nil;
                           (* 2018 mar 15 featurememoryptr is set to nil
                           so that there is no garbage *)
{vvv}
                           if lineplace+1 > wamax then wamax := lineplace;

                           (* now get the size of the bugger *)
                           ribl := matrix^.data[b,l];
                           height[lineplace] := ribl;
                           featurehere[lineplace] := f;
                           walkerposition[lineplace] := cooway*l;

                           (* determine the angle of the letter *)
                           if (matrix^.symmetry = 'a') and Sideways
                           then case cooway of
                                -1: angle[lineplace] := -90;
                                +1: angle[lineplace] := +90
                                end
                           else if ribl >= 0
                                then angle[lineplace] := 0
                                else angle[lineplace] := 180;

                           (* and figure out red/green bar *)
                           if spot = coozero
                           then if (f^.Ri > f^.definition^.RiboundFeature) and
                                   (f^.Z <= f^.definition^.ZboundFeature) and
                                   (f^.probability >= f^.definition^.PboundFeature)
                                then redgreen[lineplace] := 'g'
                                else redgreen[lineplace] := 'r';

                           (* and figure out purple/black bar.
                              Black overrides purple *)
                           if matrix^.numbers[b,l] = 0
                           then purpleblack[lineplace] := 'b'
                           else if ribl < lowerbound
                                then purpleblack[lineplace] := 'p';
                        end;
                     end;
                  end
               end
{uuuqq - may need  to work with this, but probably not.
This is the letter on the walker (rarely if not never used):}
               else fillline(spot,background.letters[1]);
               end;
            end;

            (* we were able to write out at least some of the background,
               so the feature is satisfied for this line. *)
            unsatisfied := false;
         end;

         spot := spot + 0.5;
      end;

      (* run through the feature marks and print into the arrays
         (not to be confused with the marks file!) *)
       leftedgeout := false;
      rightedgeout := false;
      if (handling[lineplace] in ['n','h','r'])
      then antiartmode := true; (* for artmode *)
      for m := 1 to marks do begin
         (* locate the zero base *)

         (* the location of the mark depends on the orientation *)
         (* something is odd here - either case is doing the same thing! *)
(* probably the case can be removed - do this later when other
things settle down...
2016sep06 but Stepvm is called inside here so maybe it is required ... *)
{
writeln(output,'- uuuccc ------- cooway: ', cooway, ', m = ',m);
}

         (* ORIGINAL WEIRD CODE:
         This code fails when the basic coordinate system is
         reversed (coopie).  But in general it works: IN PRACTICE THIS IS OK!
         BBBqqq *)
         case cooway of
            -1: spot := coozero + cooway * locations[m];
            +1: spot := coozero + cooway * locations[m];
         end;

         (* The extra 0.5 added to last in the if below allows marks between
            bases.  Note that the one on the left is suppressed to avoid two
            marks from showing up, one on the end of the previous line and one
            on the beginning of the current line. *)

         if between(first, (* suppress: -0.5 *)
                    spot,
                    last+0.5) then begin
            linefunction(spot, lineplace, inside);
            if (handling[lineplace] in ['n','h','H','r','R']) and
               inside
            then begin
               case cooway of
                  -1: fillline(spot, negparts.letters[marks-m+1]);
                  +1: fillline(spot, posparts.letters[m]);
               end;
               if ismulti then begin
                  (* Go through the features that this gap points to
                     and step the vertical memory location as
                     appropriate. *)

if superdebug then begin
{ 2004aug11:
Just step the spot!  it's a multi and we are filling the spot!!}
writeln(output);
writefeaturememory(output,verticalmemory);
writeln(output);
writeln(output,'BEFORE ASCII verticalmemory stepvm, vmmax = ',vmmax:1,
               ' linenumber = ', linenumber:2 );
end; (* superdebug if *)

{
writeln(output);
writeln(output);
writeln(output,'!!!!!!!!!!!!!!!!!! about to stepvm for f=');
showafeature(output,f);
writeln(output,'WHICH END OF f are we at??');
writeln(output,'coordinate  = ',round(coordinate):1); (* this is it! *)
writeln(output,'orientation = ',orientation:1);
writeln(output,'     cooway = ',cooway:1);
writeln(output,'  fromrange = ',fromrange:1:1);
writeln(output,'    torange = ',torange:1:1);
writeln(output,'    coozero = ',coozero:1:1);
writeln(output,'    cooleft = ',cooleft:1:1);
writeln(output,'   cooright = ',cooright:1:1);
writeln(output);
writeln(output);
}

                  (* Compute the location of the m'th gap end: *)
                  stepvm(f, lineplace,
                         inttopie(round(locations[m]
                         + realpietoint(coordinate, pie)),pie)
                        ); (* step for gaps *)

if superdebug then begin
{yyykkkjust step it!}
{uuu}
writefeaturememory(output,verticalmemory);
writeln(output);
writeln(output,'AFTER  ASCII verticalmemory stepvm, vmmax = ',vmmax:1,
               ' linenumber = ', linenumber:2 );
{ VM: is this the RIGHT lineplace???
should it be computed again??  No, we are ok, it's computed above.}
{
this is the conversion to coozero in proc setcoordinates:
   with f^ do with f^.definition^ do begin
      coozero := realpietoint(coordinate,pie);
      o^.afeature^.coordinate
realpietoint(coordinate,pie);
}
{
writeln(output,'Ppp ----------------');
writeln(output,'Ppp spot: ', spot:1:5);
writeln(output,'Ppp coozero: ', coozero:1:5);
writeln(output,'Ppp cooway: ', cooway:1);
writeln(output,'Ppp m: ', m:1);
writeln(output,'Ppp locations[m]: ', locations[m]:1:5);
}
end; (* superdebug if *)

               end;

               (* we were able to write out at least some of the
                  marks, so the feature is satisfied for this line. *)

               unsatisfied := false
            end;
         end
         else begin
            if spot < first       then  leftedgeout := true;
            if spot > last + 0.5  then rightedgeout := true;
         end
      end;
      antiartmode := false; (* for artmode *)

      if leftedgeout then begin
         antiartmode := true; (* for artmode *)
         ellipsis(first-2.0); (* two bases left of first base on the line *)
         antiartmode := false; (* for artmode *)
      end;

      if rightedgeout
      then begin
         (* write ellipsis.  last would be exactly on the last base.  We want
            to be at least one more base to the right so add 1.  Then tack on
            another 0.5 since the last character of the object is against it.
            Final total is 1.5 *);
         antiartmode := true; (* for artmode *)
         ellipsis(last+1.5);
         antiartmode := false; (* for artmode *)

         (* put JUST THE NAME of the object here!  Position it after the
            ellipsis (3 characters) plus 1 space (1 character), which is
            4 characters or 2 bases: *)
         antiartmode := true; (* for artmode *)
         putstring(nametag,last+1.5+2);
         antiartmode := false; (* for artmode *)

         (* the feature desires to be placed at the same line number
            in the set of features *)
         if featuresOnSameLine then desiredline := featurelinenumber;
      end
      else begin
         (* write out the strings *)
         antiartmode := true; (* for artmode *)
         putstring(nametag,cooright+1);
         antiartmode := false; (* for artmode *)
         putstring(othertag,cooright+1.0 + (nametag.length/2.0) + 0.5);

         if featuresOnSameLine
         then desiredline := 0; (* no further desires! *)
      end;

      if featuresOnePerLine then begin
         (* forcing one feature to a line can be implemented simply by
            converting all blanks to tabs, the invisible "hard" space used
            elsewhere in this code.  This makes the entire line unavailable
            for further features. *)
         for tabindex := 1 to linemax do
         if line[tabindex] = ' ' then line[tabindex] := chr(tabcharacter);
         actualmax := linemax;
      end;
   end;
end; (* printfeature *)
(* __________________________________________________________________________ *)

procedure writedir(var a: text; d: direction);
(* write a direction BBB
      direction = (plus, minus, dircomplement, dirhomologous);
*)
begin
   case d of
      plus:          write(a, 'plus');
      minus:         write(a, 'minus');
      dircomplement: write(a, 'dircomplement');
      dirhomologous: write(a, 'dirhomologous');
   end
end;

procedure setcoordinates;
(* set up the three coo variables.  The left and right
range depend on the orientation of the feature. *)
{BBB it may be that this applies only to the walker.
The ascii feature doesn't care about sequences ...}
begin
(* writeln(output,'setcoordinates');{QQQ} *)
{
writeln(afile);
writeln(afile,'setcoordinates');
showafeature(afile, f);
}
{
write(output, 'setcoordinates'); report(output, f);
}
   with f^ do with f^.definition^ do begin
(* writeln(output,'piebeg = ', piebeg:1); {QQQ} *)
(* writeln(output,'coobeg = ', coobeg:1); {QQQ} *)
(* writeln(output,'cooend = ', cooend:1); {QQQ} *)
(* writeln(output,'coordinate for making coozero: ',coordinate:5:1);{QQQ} *)
      coozero := realpietoint(coordinate,pie);
{writeln(output,'COOZERO coozero = ',coozero:10:2);}

      (* 2004 July 20: distinguish between ascii and walkers: *)
      if background.length = 1 then begin
(* write(output,'setcoordinates ASCII=======');{QQQ} *)
(* writequotestring(output,nametag);writeln(output);{QQQ} *)
         (* method for ascii features *)
         if (pie^.key.piedir = plus) or
            (pie^.key.piedir = dirhomologous)
(*
if pie^.key.piedir = pie^.key.coodir {QQQ STOLEN FROM BELOW!}
*)
         then cooway := +orientation
         else cooway := -orientation;
      end
      else begin
         (* method for sequence walkers *)
{jjj}
         if pie^.key.piedir = pie^.key.coodir
         then cooway := +orientation
         else cooway := -orientation;
      end;

      (* if the other direction, use opposite range *)
      if cooway = +1
      then begin
         cooleft  := coozero + fromrange;
         cooright := coozero +   torange;
      end
      else begin
         cooleft  := coozero -   torange;
         cooright := coozero - fromrange;
      end;

{QQQcore}
(* writeln(output,'orientation = ',orientation:1); {QQQ} *)
(* writeln(output,'     cooway = ',cooway:1); {QQQ} *)
(* writeln(output,'  fromrange = ',fromrange:1:1); {QQQ} *)
(* writeln(output,'    torange = ',torange:1:1); {QQQ} *)
(* writeln(output,'    coozero = ',coozero:1:1); {QQQ} *)
(* writeln(output,'    cooleft = ',cooleft:1:1); {QQQ} *)
(* writeln(output,'   cooright = ',cooright:1:1); {QQQ} *)
(*
*)

{
writeln(output,'orientation = ',orientation:1);
writeln(output,'     cooway = ',cooway:1);
writeln(output,'  fromrange = ',fromrange:1:1);
writeln(output,'    torange = ',torange:1:1);
writeln(output,'    coozero = ',coozero:1:1);
writeln(output,'    cooleft = ',cooleft:1:1);
writeln(output,'   cooright = ',cooright:1:1);
}

   end;
end; (* setcoordinates *)

procedure preprintfeature;
(* set up to print feature f *)
begin
(* writeln(output);{QQQ} *)
(* writeln(output,'preprintfeature BEG'); writeafeature(output,f);{QQQ} *)
(* writeln(output);{QQQ} *)
   with f^ do with f^.definition^ do begin
      setcoordinates;

      (* test for collision of the feature with the space *)
      (* we add 1 character to account for the space before the tag and 1
         to account for a space after.  *)
      if openspace(cooleft,
                   cooright+(1+nametag.length+1+othertag.length+1)/2.0)
      then printfeature
(* else writeln(list,'DID NOT PRINT FEATURE!'){QQQ} *)
{
else if debug then writeln(list,'DID NOT PRINT FEATURE!')
}
   end;
(* writeln(output,'preprintfeature END'); writeafeature(output,f);{QQQ} *)
(* writeln(output);{QQQ} *)
end; (* preprintfeature *)

begin (* writethefeatures *)
   if mapcontrol then begin
      writeln(map);
      writeln(map,'% writethefeatures');
   end;

   firstedge := first (* - 0.5 *); (* we suppress the left edge to
      avoid duplication: it has been handled on the previous line *)
   lastedge :=  last + 0.5;

   (* mark just those features that are in the range *)
   f := featurelist;
   printsomefeatures := false; (* be optimistic *)
   while f <> nil do begin
      with f^ do with f^.definition^ do begin
         if (not KeepDuplicates) and (f^.duplicateprevious <> nil)
         then begin
            (* don't keep duplicates AND this is a duplicate! *)
            unsatisfied := false; (* pretend it is not there! *)
         end
         else begin (* set the satisfaction based on whether
                       the feature is in this printing line *)
            unsatisfied := true;
            if isnamestring(pie^.key.hea.keynam, id) then begin
               setcoordinates;
               if (* either end point is within the line *)
                  (between(firstedge,cooleft ,lastedge) or
                   between(firstedge,cooright,lastedge))
                  or
                  (* both points are outside the line *)
                  (between(cooleft,firstedge,cooright) and
                   between(cooleft,lastedge ,cooright))

               then begin
                  printsomefeatures := true;
                  oneunsatisfied := true;
               end
               else unsatisfied := false;
               (* turn off only when not within the range *)
            end
            else unsatisfied := false; (* turn off if it's the wrong piece! *)
         end;
      end;
      f := f^.next
   end;

   (* run through the features trying to place them *)
   featurelinenumber := 1;
   (* totally clear the line *)
   actualmax := linemax; clearlines;
   if printsomefeatures then while oneunsatisfied do begin
      (* be optimistic we will be done this time *)
      oneunsatisfied := false;

      (* loop through to find any feature which demands
         to be printed on this line, and satisfy it first. *)
      if featuresOnSameLine then begin
         barger := 0;
         fbarger := nil;
         f := featurelist; (* start over again with a new line *)
         while f <> nil do with f^ do with f^.definition^ do begin
            if unsatisfied then begin
               if desiredline = featurelinenumber then begin
                  barger := succ(barger);
                  if barger > 1 then begin
                     writeln(list,'featurelinenumber=',featurelinenumber:1);
                     writeln(list,'desiredline=',desiredline:1);
                     writeln(list,'f^.desiredline=',f^.desiredline:1);
                     writeln(list,  'Two features tried to print',
                                    ' on the same line!  barger =', barger:1);
                     writeln(output,'Two features tried to print',
                                    ' on the same line!  See list file.');
                     write(list,'first-: '); report(list,fbarger);
                     write(list,'2nd---: '); report(list,f);
                     writeln(list);
                     writeln(list,'All features:');
                     writeln(list);
                     writeln(list,'The curent line is:');
                     writetheline;
                     writeln(list,'featurelinenumber=',featurelinenumber:1);
                     writeln(list,'desiredline=',desiredline:1);

                     {1999 May 8:  the barger bug is probably solved: 
                      It was caused by the desires of the features on
                      previous pieces.  By setting the desires to the
                      initial state the problem cleared.  See lll}

                     halt
                  end;
                  (* record the initial one that barged in; *)
                  if barger = 1 then begin
                     fbarger := f;
                  (* this feature demands being printed on this line,
                     so satisfy the demand immediately before any other
                     features get a chance.  If there is another feature
                     that 'thinks' it needs this line, then we'll catch it *)
                     preprintfeature;
                  end;
               end
            end;
            f := f^.next;
         end;
      end;

      (* loop through and print each feature that we can *)
      f := featurelist; (* start over again with a new line *)
      while f <> nil do with f^ do with f^.definition^ do begin
         (* if this feature is not printed yet, see if we can do so *)
         if unsatisfied (* gota be unsatisfied to want to print *)
            and
            (
              ( featuresOnSameLine  (* demanding same line *)
                and
                (
                  (desiredline = featurelinenumber) (* gota be THE line *)
                    or
                  (desiredline = 0) (* don't care which line *)
                )
              )
              or
              (not featuresOnSameLine)  (* not demanding same line *)
            )
         then preprintfeature;

         (* If the feature was unsatisfied this time for printing, then not
            all features were satisfied, so we must continue to try to
            print. *)
         if unsatisfied then oneunsatisfied := true;

         f := f^.next;
      end;

      (* Check for features that are unsatisfied that will never be.
         Stop them from printing.  This avoids an infinite loop,
         but it indicates a program error. *)
      if featuresOnSameLine then begin
         f := featurelist;
         while f <> nil do with f^ do with f^.definition^ do begin
            if unsatisfied and (desiredline > 0) then begin
               if desiredline < featurelinenumber then begin
                  writeln(output,'PROGRAM ERROR: INFINITE LOOP AVERTED');
                  writeln(list,'PROGRAM ERROR: INFINITE LOOP AVERTED');
                  desiredline := 0;
                  unsatisfied := false;
               end;
            end;
            f := f^.next;
         end;
      end;

      writetheline; (* put out what we have so far *)
      clearlines;
   end;
if debug then showfeatures(list, featurelist, true);
end;
(* end module writethefeatures *)

(* begin module listdatalines *)
procedure listdatalines(var afile, map: text; pie: pieceptr;
                        shiftsequence: integer; line: linetype;
                        giveframes: boolean);
(* list the data lines of sequence pie in ndaf order to afile and map.
Shift shiftsequence bases to the right for the first line.
   giveframes: boolean; show all amino acid frames without emphasis
*)
var
   i: integer; (* index to ndaf *)
   goalline: integer; (* the goal line number for totallineswritten
      which we have to reach to satisfy the MinimumLines parameter *)
   length: integer; (* of pie *)
   frame0, frame1, frame2: state; (* which frames are on *)
   InitiationRegionName: string; (* name of ir feature *)
   hue0, saturation0, brightness0,
   hue1, saturation1, brightness1,
   hue2, saturation2, brightness2:
      real; (* colors for each open reading frame emphasis *)
   emphasis0, emphasis1, emphasis2: state; (* which on frames
      are to be emphasized with underscore/colored boxes *)
   framefeature0, framefeature1, framefeature2: featuretypeptr;
      (* features for each frame *)
   framecodoncount0, framecodoncount1, framecodoncount2: integer;
      (* counts of open reading frame lengths *)
   first, last: integer; (* positions in pie *)
   b1,b2,b3: base; (* the first codon, used for a special case *)
procedure lookback(framejump: integer; var frame: state);
(* look back to see if the frame should be on. *)
var
   index: integer; (* index to pie *)
      aa: aminoacid; (* the aa at index *)
begin
   index:=length+framejump-2;
   frame:=off; (* if no start is found *)

   while index > 0 do begin
      getaminoacid(index,pie,aa);
      if (aa='amb') or (aa='och') or (aa='opa')
      then begin
         index:=0;
         frame:=off
      end
      else if (aa='met') or ((aa='val') and (getbase(index+2,pie)=g))
      then begin
         index:=0;
         frame:=on
      end;
      index:=index-3; (* back up a codon *)

      (* if we have scanned all the way down, and did not find anything
         and there are more frames accessable (length is not divisible by
         three), then we continue to scan from the top again.
         at most 3 passes across the piece can occur. *)
      if (index=2) or (index=3) then index:=length-(3-index)
   end
end;
procedure domarks;
(* do the marks *)
begin
   if mapcontrol
   then if not waitfornextpiece then begin
     if firstone
     then writemarks(map, marks, first, last, shiftsequence)
     else writemarks(map, marks, first, last, 0);
   end;
end;
begin
   length:=piecelength(pie);

   (* if pie is circular, we can look backwards to decide
      which frames should be on. *)
   if pie^.key.piecon = circular then begin
      lookback(0,frame0);
      lookback(1,frame1);
      lookback(2,frame2);
   end
   else begin (* start with all frames on *)
      frame0 :=  on;
      frame1 := on;
      frame2 := on;

      (* emphasis is off initially *)
      emphasis0 := off;
      emphasis1 := off;
      emphasis2 := off;
      framefeature0:= nil;
      framefeature1:= nil;
      framefeature2:= nil;
      framecodoncount0:= 0;
      framecodoncount1:= 0;
      framecodoncount2:= 0;

      (* define the name of the initiation region feature *)
      with InitiationRegionName do begin
        letters[1] := 'i';
        letters[2] := 'r';
        current := 1;
        length := 2;
        next := nil;
      end;

{444555}

      hue0 := 0; saturation0 := 0; brightness0 := 0;
      hue1 := 0; saturation1 := 0; brightness1 := 0;
      hue2 := 0; saturation2 := 0; brightness2 := 0;

      (* special case:
      A linear piece that starts with aug, gug or uug is usually the
      start of a gene.  To be nice, we should list it as fMet.  To do
      so requires that the frame be off first. *)
      if length >= 3 then begin
         b2:=getbase(2,pie);
         b3:=getbase(3,pie);
         if (b2=t) and (b3=g) then begin
            b1:=getbase(1,pie);
            if (b1=a) or (b1=g) then frame0:=off
         end
      end
   end;

   first := 1;
   firstone := true;

   (* pass across the entire DNA sequence *)
   while first <= length do begin
      (* break the DNA sequence in to lines of first .. last *)
      if firstone
      then last:=first+basesperline-1-shiftsequence
      else last:=first+basesperline-1;
      if last > length then last:=length;

      goalline := totallineswritten + MinimumLines;

      (* if the page would break the packet, page first *)
      if linenumber + packet - 1 > pagelength
      then nextpage(afile,map,mapcontrol,
                    linenumber,pagenumber,basesperline);

      (* packet of lines for the line of dna: *)
      nextline(afile,map,mapcontrol,true,
               linenumber,pagenumber,basesperline, dummy, line);

      if marksorder = 'b' then begin
         (* marks are written first so they underlie everything else *)
         domarks;
      end;

      (* display the data lines in the requested order *)
      for i := 1 to maxdatacontrol do begin
         case ndaf[i] of
            'N': begin
                 writenumbers(afile,map,mapcontrol,pie,first,last,line);
                 if marksorder = 'N' then domarks;
            end;

            'D': begin
               case seqlines of
                  0:;
                  1: writedna(afile,map,mapcontrol,pie,first,last,false,
                              line);
                  2: begin
                     writedna(afile,map,mapcontrol,pie,first,last,false,
                              line);
                     writedna(afile,map,mapcontrol,pie,first,last,true,
                              line);
                  end;
               end;
               if marksorder = 'D' then domarks;
            end;

            'F': begin
                 writethefeatures(afile, map, mapcontrol,
                                  linenumber, pie, featurelist, first, last,
                                  featuresOnSameLine, featuresOnePerLine);
                 if marksorder = 'F' then domarks;
            end;

            'A': begin
                 if aastate <> 0 then begin
                    if frame0allowed
                       then writeaminoacids(afile,map,mapcontrol,
                                         pie,first,last,0,
                              frame0, framecodoncount0,
                              line,
                              InitiationRegionName, giveframes, featurelist,
                              framefeature0,
                              emphasis0,
                              hue0, saturation0, brightness0);
                    if frame1allowed
                       then writeaminoacids(afile,map,mapcontrol,
                                            pie,first,last,1,
                              frame1, framecodoncount1,
                              line,
                              InitiationRegionName, giveframes, featurelist,
                              framefeature1,
                              emphasis1,
                              hue1, saturation1, brightness1);
                    if frame2allowed
                       then writeaminoacids(afile,map,mapcontrol,
                                            pie,first,last,2,
                              frame2, framecodoncount2,
                              line,
                              InitiationRegionName, giveframes, featurelist,
                              framefeature2,
                              emphasis2,
                              hue2, saturation2, brightness2);
{444}
                 end;
                 if marksorder = 'A' then domarks;
            end;

            'n','d','f','a': (* do nothing *);

         end;

      end;

      if firstone then
      begin
         firstone := false;
         first := first + basesperline - shiftsequence;
      end
      else first := first + basesperline;

      (* write out lines until we have done at least
         MinimumLines all together for this line of sequence *)
      while totallineswritten < goalline
      do nextline(afile,map,mapcontrol,true,
            linenumber,pagenumber,basesperline, dummy,
                              line);

   end;
   nextline(afile,map,mapcontrol,true,
            linenumber,pagenumber,basesperline, dummy,
                              line);
end;
(* end module listdatalines *)

(* begin module showpiece *)
procedure showpiece(var afile: text; pie: pieceptr; nkfc: array4);
(* show the information for the piece.  nkfc control
the number, key name, full name and coordinates - capital letters
turn these on. *)
(* showpiece and the main program with variables, are
   derived from the program sear (book searcher) version 1.09,
   from the procedure called multimatch. *)
var
   commacount: integer; (* count of number of commas already put
     out.  If it is > 0, don't put a new comma out *)
   i: integer; (* index to fulnam *)
procedure comma;
begin
  if commacount < 1 then write(afile,', ');
  commacount := succ(commacount);
end;
procedure dobackslash;
(* handle backslashes for book full names *)
const
   backslash = '\'; (* the backslash character *)
var
   c: char; (* a character *)
begin
   c := pie^.key.hea.fulnam^.letters[i];
   if c <> backslash then begin
      if i > 1
      then if pie^.key.hea.fulnam^.letters[i-1] = backslash
           then write(afile,c)
           else begin
              protectpostscript(afile, c);
              write(afile,c);
           end
      else begin
              protectpostscript(afile, c);
              write(afile,c);
           end
   end
   else begin
      if i > 1
      then if pie^.key.hea.fulnam^.letters[i-1] = backslash
           then write(afile,c)
   end
end;
begin
      commacount := 1; (* pretend for the first item that there
         was something before hand so that it does not have a comma
         in front of it! *)
      with pie^.key do begin
         if nkfc[1] = 'N' then begin
            comma; (* this line here for symmetry *)
            write(afile,' piece');
            if numbered then write(afile,' ',number:1);
            commacount := 0;
         end;

         if nkfc[2] = 'K' then begin
            comma;
            with hea.keynam do write(afile,letters:length);
            commacount := 0;
         end;

         if nkfc[3] = 'F' then begin
            if pie^.key.hea.fulnam^.length > 0 then begin
               comma;
               for i := 1 to pie^.key.hea.fulnam^.length
               do dobackslash;
               commacount := 0;
            end;
         end;

         if nkfc[4] = 'C' then begin
            comma;
            write(afile,'config: ');
            if piecon=linear then write(afile,'linear,')
                             else write(afile,'circular,');
            write(afile,' direction: ');
            if piedir=plus then write(afile,'+,')
                           else write(afile,'-,');
            write(afile,' begin: ',piebeg: 1,',',
                        ' end: ', pieend:1);
            commacount := 0; (* this line here for symmetry *)
         end;
      end;
end;
(* end module showpiece *)

(* begin module readname *)
procedure readname(var afile: text; var id: name);
(* read a name from afile, code is similar to brname.
This routine is not needed now because it is replaced by
standard string reads. *)
var
   c: char; (* a character read *)
   i: integer; (* an index *)
begin
   skipblanks(afile);
   with id do begin
      length:=0;
      repeat
         length:=succ(length);
         read(afile,c);
         letters[length] := c
      until (eoln(afile)) or
            (length>=namelength) or
            (c=' ');
      if letters[length]=' ' then length:=length-1;
      if length<namelength
         then for i:=length+1 to namelength do letters[i]:=' '
   end;
end;
(* end module readname *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

{ ORIGINAL LOCATION of this locatefeature - moved
much higher on 2007 Mar 15.  Can move other stuff too ...
}

(* begin module readdefinitionsandfeatures *)
procedure readdefinitionsandfeatures(var afile: text;
                       var KeepDuplicates: boolean;
{zzzccc}
                       var comments: stringptr;
                       var definitionlist: definitiontypeptr;
                       var featurelist: featuretypeptr;
                       var groupnumber: integer;
                           windowsize: integer);
{
                       var localRDAFvariables: 
                           readdefinitionsandfeaturesVariables);
}
(* Read definitions and features from afile.

These are defined in the lister.p program.

* Keep duplicate features if KeepDuplicates is true.
* comments records comment strings
* comments records comment strings
* definitionlist: definitions of features
* featurelist: list of features
* groupnumber: number of the group of features we are working on
* window: size in bases to compare features

* localRDAFvariables: is a global that acts as local variables for
  this procedure.  ALL local variables are passed through this
  variable so that the procedure can remember them.
  This allows the afile to be read in chunks separated by the
  windowsize.

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

2022 Dec 16: if window > 0 make circular group list
????

*)

{ ALL LOCAL VARIABLES ARE CARRIED IN readdefinitionsandfeaturesVariables
var
   verbose: boolean; (* give verbose output *)
   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 *)
   (* 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 with localRDAFvariables do begin
{zzzrrr}
{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; end; (* addmotherlinks *)

begin with localRDAFvariables do 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;
         countmarks(groupTotalFeature,-1); (* final check *)

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

               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,'SUPERDEBUG gap is ',gap:1);
writestring(output, leftstring);writeln(output,'<-  leftstring SUPERDEBUG');
writestring(output,rightstring);writeln(output,'<- rightstring SUPERDEBUG');
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;
                  ff := ff^.next;
               end;

if superdebug then begin
write(output,'SUPERDEB leftgap: '); writeafeature(output,leftgap); writeln(output);
write(output,'SUPERDEB 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,'SUPERDEB 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,'SUPERDEB: 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,'SUPERDEB 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);
               (* now alter aGapFeature so that it points to the
                  non-duplicate feature! *)
               (* 2016oct30: KEY CHANGE to fix hindi problem! *)
               if (not aGapFeature^.definition^.isgap)
               then aGapFeature^.others^.afeature := gg^.duplicateprevious;
            end;
            gg := gg^.next;
         end;

if superdebug then begin
writeln(output,'SUPERDEBUG: 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; (* end threadgroup *)

begin with localRDAFvariables do begin (* readdefinitionsandfeatures *)
{
   if (window <= 0) then begin
}
      reset(afile);
   verbose := false;
   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;

   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);}
         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
                  if equaldefinition(dtest, d)
                     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.');
                     barout;

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

                     uniquedefinitions := pred(uniquedefinitions);
                  end;
                  if not done then begin (* step forward *)
                     dtest := dtest^.next;
                  end;
               end;
            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);
               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 > 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;
               countpetals := succ(countpetals);
            end;
         end

         else if identifier = '@'
         then begin (* read feature *)
            countfeatures := succ(countfeatures);
            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 *)
(* 2022 dec 16: I moved the code here because the parts under the
(* following if statment were identical *)
               f^.next := newfeature;
               f := f^.next;
               f^.featurenumber := countfeatures;
               f^.featuregroup := groupnumber;
               f^.featureisfirstingroup := firstfeatureofgroup;

               if not featureinlist(featurelist, newfeature, oldfeature)
               then begin
                  uniquefeatures := succ(uniquefeatures);
               end
               else begin
                  if verbose then begin
                     writeln(output,'This feature was found more than once:');
                     writeafeature(output,newfeature);
                     writeln(output);
                  end;
                  if KeepDuplicates
                  then begin
                     (* Keep all duplicates in the list! *)
                     if verbose then writeln(output,'It is being kept.');
                     f^.duplicateprevious := nil;
                  end
                  else begin
                     if verbose then writeln(output,'It will be ignored.');
                     f^.duplicateprevious := oldfeature;
                  end

               end
            end;
            if firstfeatureofgroup then firstfeatureofgroup := false;

            threadgroup;
{ttt Is this the right place to examine the list or should it be later?}
         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;

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

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; (* readdefinitionsandfeatures *)
(* end module readdefinitionsandfeatures version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module lister.upgradeto992 *)
procedure upgradeto992(var listerp: text);
(* upgrade the listerp file to version 9.92:
allow control of all bounding box edges with pageedges etc. on new line 19.
n 0 0 0 0   edgecontrol (p=page), edgeleft, edgeright, edgelow, edgehigh in cm
*)
const
   copylines = 18; (* the number of copied lines *)
var
   internal: text; (* a place to hold the old listerp *)
   line: integer; (* a line to be worked with *)
{  parameterversion: real; (* parameter version number *)}
begin
   parameterversion := 9.92;
   writeln(output, 'upgrading to version ',parameterversion:4:2,' ...');

   (* copy alist to internal *)
   reset(listerp);
   readln(listerp); (* skip old parameter version line *)
   rewrite(internal);
   for line := 1 to copylines
   do copyaline(listerp, internal);

   (* write the NEW PARAMETER LINE *)
   writeln(internal,
           'n 0 0 0 0   edgecontrol (p=page),',
           ' edgeleft, edgeright, edgelow, edgehigh in cm');

   (* finish the copy of alist to internal *)
   copyfile(listerp, internal);

   (* copy internal to alist *)
   reset(internal);
   rewrite(listerp);
   writeln(listerp,parameterversion:4:2,'        version of',
         ' listerp that this parameter file is designed for.');
   copyfile(internal, listerp);

   (* add the new material at the end: *)
   (* none to add *)

   reset(listerp); (* ready to start reading again *)

end;
(* end module lister.upgradeto992 *)

(* begin module lister.upgradeto1045 *)
procedure upgradeto1045(var listerp: text);
(* upgrade the listerp file from 9.92 to version 10.45.
The DEFINED order of parameters is edgecontrol followed by KeepDuplicates.
But version 9.92 hase these reversed.  Fix that.
Introduce artmode variable.
*)
var
   internal, internal1, internal2: text; (* a place to hold the old listerp *)
   line: integer; (* a line to be worked with *)
{  parameterversion: real; (* parameter version number *)}
begin
   parameterversion := 10.45;
   writeln(output, 'upgrading to version ',parameterversion:4:2,' ...');

   (* first reverse lines 19 and 20 so that edgecontrol is before
      KeepDuplicates *)

   (* copy alist to internal *)
   reset(listerp);
   readln(listerp);
   (* skip old parameter version line *)
   rewrite(internal);
   for line := 2 to 18 (* up to pageedges *)
   do begin
      if not eof(listerp)
      then copyaline(listerp, internal);
   end;

   (* read the next two lines *)
   rewrite(internal1);
   copyaline(listerp, internal1);
   rewrite(internal2);
   copyaline(listerp, internal2);

   (* write the two lines out in reversed order: *)
   reset(internal2);
   copyaline(internal2, internal);
   reset(internal1);
   copyaline(internal1, internal);

   (* copy the rest of the lines *)
   while not eof(listerp) do copyaline(listerp,internal);

   (* write the NEW PARAMETER LINE *)
   writeln(internal,
           '-     artmode: a(rtmode), b/B(lack), n(ames), otherwise normal.');

   (* finish the copy of alist to internal *)
   copyfile(listerp, internal);

   (* copy internal to alist *)
   reset(internal);
   rewrite(listerp);
   writeln(listerp,parameterversion:4:2,'        version of',
         ' listerp that this parameter file is designed for.');
   copyfile(internal, listerp);

   (* add the new material at the end: *)
   (* none to add *)

   reset(listerp); (* ready to start reading again *)

end;
(* end module lister.upgradeto1045 *)

{ooo}
(* begin module lister.upgradeto1155 *)
procedure upgradeto1155(var listerp: text);
(* upgrade the listerp file from 10.45 to version 11.55.
Introduce outline variable.
*)
var
   internal: text; (* a place to hold the old listerp *)
   line: integer; (* a line to be worked with *)
{  parameterversion: real; (* parameter version number *)}
begin
   parameterversion := 11.55;
   writeln(output, 'upgrading to version ',parameterversion:4:2,' ...');

   (* copy the rest of the lines *)
   rewrite(internal);
   reset(listerp); (* skip the first line *)
   readln(listerp); (* skip the first line *)
   while not eof(listerp) do copyaline(listerp,internal);

   (* write the NEW PARAMETER LINE *)
   writeln(internal,
           'n 0.3 0.0 outline: o(utline), outlinewidth, outlinegray');
   (* it defaults to be off *)

   (* copy internal to listerp *)
   reset(internal);
   rewrite(listerp);
   writeln(listerp,parameterversion:4:2,' version of',
         ' listerp that this parameter file is designed for.');
   copyfile(internal, listerp);

   (* add the new material at the end: *)
   (* none to add *)

   reset(listerp); (* ready to start reading again *)

end;
(* end module lister.upgradeto1155 *)
{ooo}

{PPP}
(* begin module lister.upgradeto1309 *)
procedure upgradeto1309(var listerp: text);
(* upgrade the listerp file from 11.55 to version 13.09.
Introduce outline horizontal and vertical bar variables.
*)
var
   internal: text; (* a place to hold the old listerp *)
   line: integer; (* a line to be worked with *)
{  parameterversion: real; (* parameter version number *)}
begin
   parameterversion := 13.09;
   writeln(output, 'upgrading to version ',parameterversion:4:2,' ...');

   (* copy the rest of the lines *)
   rewrite(internal);
   reset(listerp); (* skip the first line *)
   readln(listerp); (* skip the first line *)
   while not eof(listerp) do copyaline(listerp,internal);

   (* write the NEW PARAMETER LINES *)

   writeln(internal,
           'h+ 1.0 1.0 horizontal: h(orizontal bar) - width height');
{HHH}
   (* it defaults to be on *)

   writeln(internal,
           'v| 1.0 1.0 vertical: v(ertical bar) | width height');
{VVV}
   (* it defaults to be on *)

   (* copy internal to listerp *)
   reset(internal);
   rewrite(listerp);
   writeln(listerp,parameterversion:4:2,' version of',
         ' listerp that this parameter file is designed for.');
   copyfile(internal, listerp);

   (* add the new material at the end: *)
   (* none to add *)

   reset(listerp); (* ready to start reading again *)

end;
(* end module lister.upgradeto1309 *)
{ooo}


(* begin module lister.upgradeparameters *)
procedure upgradeparameters(var listerp: text);
(* make sure that the parameters are the latest spiffy version *)
{2016 Sep 22: I made parameterversion global so that updates pass the value along
var
}
{  parameterversion: real; (* parameter version number *)}

(* Since parameters are real numbers, there can be round off errors in
the 15th decimal place that prevent comparisons.  However, I only use
parameters to 2 decimal places, so we can multipy by 100 and round to
do reliable comparisons. *)

function r100(a: real): integer;
(* simple multiply and round function *)
begin
 r100 := round(100*a);
end;

function equalversion(a,b: real): boolean;
(* Are versions a and b equal? *)
begin
   if r100(a) = r100(b)
   then equalversion := true
   else equalversion := false
end; (* equalversion *)

function lessthan(a,b: real): boolean;
(* Is version a less than b? *)
begin
   if r100(a) < r100(b)
   then lessthan := true
   else lessthan := false
end; (* lessthan *)

function greaterthan(a,b: real): boolean;
(* Is version a greater than b? *)
begin
   if r100(a) > r100(b)
   then greaterthan := true
   else greaterthan := false
end; (* greaterthan *)

begin
   readln(listerp, parameterversion);

   if    lessthan(parameterversion, updateversion) or
      greaterthan(parameterversion, versionupperbound)
   then begin
      writeln(output, 'You have an old parameter file!, version ',
              parameterversion:4:2,'!');
      writeln(output, '          version = ',          version:4:2);
      writeln(output, '    updateversion = ',    updateversion:4:2);
      writeln(output, ' parameterversion = ', parameterversion:4:2);
      writeln(output, 'versionupperbound = ',versionupperbound:4:2);

      if equalversion(parameterversion,  8.62) then upgradeto992(listerp);
      if equalversion(parameterversion,  9.92) then upgradeto1045(listerp);
      if equalversion(parameterversion, 10.45) then upgradeto1155(listerp);
{
writeln(output,'parameterversion=',parameterversion:4:2);
halt;
}
      if equalversion(parameterversion, 11.55) then upgradeto1309(listerp);
{VVVPPP}

      reset(listerp);
      readln(listerp, parameterversion);
      if lessthan(parameterversion , updateversion) then begin
         writeln(output, 'Sorry! I am unable to fully upgrade',
                         ' your parameter file');
         writeln(output, 'from version ', parameterversion:4:2,
                          ' to version ', updateversion:4:2,'!');
         writeln(output, 'Start from a fresh copy or edit this one.');
         halt;
      end
      else writeln(output, '... upgrade to version ',parameterversion:4:2,
                           ' was successful!');

      writeln(output, 'See this page for the new documentation:');
      writeln(output,
         'https://alum.mit.edu/www/toms/delila/lister.html');
   end;
end;
(* end module lister.upgradeparameters *)

(* begin module readparameters *)
procedure readparameters(var listerp: text);
(* read user's commands *)
var
   checkout: boolean; (* if true, all variable values are ok *)
   i: integer; (* index to the ndaf array  *)
   n: integer; (* a possible trigger or the stopnumber *)
   stopnumber: integer; (* the number to stop the trigger list *)

procedure cn;
(* short version of call to check number *)
begin
  checkout := checknumber(listerp);
  if not checkout then begin
     writeln(output,'lister readparameters: halt to avoid snoballing');
     writeln(output,'A number was expected but not found.');
     if eof(listerp)
     then writeln(output,'Unexpected End of File')
     else if eoln(listerp)
          then writeln(output,'Unexpected End Of Line')
          else writeln(output,'The bad character in listerp is: "',
                    listerp^,'"');
     halt; (* avoid snowballing *)
  end;
end;

begin
   checkout := true; (* be optimistic *)
   reset(listerp);
   if not eof(listerp) then begin
      cn; upgradeparameters(listerp);

      cn; readln(listerp, basesperline);
      cn; readln(listerp, aastate);
          (* giveframes is controlled by aastate < 0 *)
          if aastate < 0 then begin
             giveframes := true; (* force true *)
             aastate := -aastate; (* normalize the variable for later use *)
          end
          else begin
             giveframes := false; (* default *)
          end;
      cn; readln(listerp, frameallowed);
      cn; readln(listerp, codelength);
      cn; readln(listerp, seqlines);
          readln(listerp, pageaction);
      cn; readln(listerp, pagelength);
          readln(listerp, hopi[1],hopi[2],hopi[3],hopi[4],
                          nkfc[1],nkfc[2],nkfc[3],nkfc[4]);
          readln(listerp, ndaf[1],ndaf[2],ndaf[3],ndaf[4]);
          readln(listerp, sof[1],sof[2],sof[3]);

      readln(listerp,pagetrigger);
      if decapitalize(pagetrigger) = 'q'
      then begin
         writeln(output,'WARNING: pagetrigger q is no longer used');
      end;
      if decapitalize(pagetrigger) = 'l'
      then begin (* get the list of trigger numbers *)
         if not (listerp^ in ['0','1','2','3','4','5','6','7','8','9'])
         then begin
            writeln(output,'A list of numbers must be given below the',
                           ' pagetrigger line when the pagetrigger is l or L!');
            halt
         end;
         read(listerp, stopnumber);

         new(ptrigs);
         ptrigs^.next := nil;
         (* the first one is the stop number *)
         ptrigs^.trigger := stopnumber;
         ptrig := ptrigs;

         n := stopnumber + 1;
         while n <> stopnumber do begin
            read(listerp,n);
{writeln(output,'n = ',n:3);}
            new(ptrig^.next);
            ptrig := ptrig^.next;
            ptrig^.trigger := n;
            ptrig^.next := nil;
         end;
         ptrig := ptrigs^.next; (* the second one is the list start *)
         readln(listerp);
      end;

      read(listerp,colorlistcontrol);
      if colorlistcontrol in ['C','R'] then begin
         mapcontrol := true;
         cn;  readln(listerp, fontsize);
      end
      else begin
         readln(listerp);
         mapcontrol := false;
      end;
      cn; read(listerp,deltaXcm);
      cn; read(listerp,deltaYcm);
      cn; readln(listerp,scaleimage);
      cn; readln(listerp,lowerbound);
      upperbound := +2; (* default is standard *)
      cn; readln(listerp,figurebottom);
      cn; readln(listerp,shiftsequence);

      read(listerp,pageedges,pageboundaries);
      cn; readln(listerp,extraright);

      read(listerp, edgecontrol);
      if (edgecontrol = 'p')
      then begin
         cn; read(listerp, edgeleft);
         cn; read(listerp, edgeright);
         cn; read(listerp, edgelow);
         cn; read(listerp, edgehigh);
      end
      else begin
          edgeleft := 0.0;
          edgeright := 0.0;
          edgelow := 0.0;
          edgehigh := 0.0;
      end;
      readln(listerp);

      if listerp^ = 'k' then KeepDuplicates := true
                        else KeepDuplicates := false;
      readln(listerp);
      if listerp^ = 's' then Sideways := true
                        else Sideways := false;
      readln(listerp);
      cn; readln(listerp,MinimumLines);
      readln(listerp,artmode);
{ writeln(output, 'artmode is "',artmode,'"'); }

      read(listerp,outline);
      cn; read(listerp,outlinewidth);
      cn; read(listerp,outlinegray);
      readln(listerp);
{ooo}

{VVV}
      (* controls for horizontal and vertical bars, produced by letterrectangle *)
      horizontalbarwidth  := 1.0;
      horizontalbarheight := 1.0;
      horizontalbarcharacter := '|';
      dovertical := defaultdovertical;
      verticalbarwidth  := 1.0;
      verticalbarheight := 1.0;
      verticalbarcharacter := '|';

      if listerp^ = 'h' then dohorizontal := true
                        else dohorizontal := false;
      get(listerp); (* move past the first character *)
      read(listerp,horizontalbarcharacter);
      cn; read(listerp,horizontalbarwidth);
      cn; read(listerp,horizontalbarheight);
      readln(listerp);

      if listerp^ = 'v' then dovertical := true
                        else dovertical := false;
      get(listerp); (* move past the first character *)
      read(listerp,verticalbarcharacter);
      cn; read(listerp,verticalbarwidth);
      cn; read(listerp,verticalbarheight);
      readln(listerp);

{ooo}

   end
   else begin (* default values *)
      basesperline:=defbasesperline;
      giveframes := true; (* show all amino acid frames without emphasis *)
      aastate:=defaastate;
      frameallowed := defframeallowed;
      codelength:= defcodelength;
      seqlines:=defseqlines;
      pagelength := defpagelength;
      pageaction := defpageaction;
      hopi := defhopi;
      nkfc := defnkfc;
      ndaf:= defndaf;
      sof:= defsof;
      pagetrigger := ' ';
      colorlistcontrol := ' ';
      mapcontrol := true;
      fontsize := 10;
      deltaXcm := 0.0;
      deltaYcm := 0.0;
      scaleimage  := 1.0;
      lowerbound := -3;
      upperbound := +2; (* default is standard *)
      figurebottom := -3;
      shiftsequence := 0;
      pageedges := 'd';
      pageboundaries := 'b';
      extraright := 0;
      KeepDuplicates := true;
      Sideways := true;
      MinimumLines := 0;
      artmode := 'n';
      outline := 'n';
      outlinewidth := 0.3;
      outlinegray := 0.0;

      (* controls for horizontal and vertical bars, produced by letterrectangle *)
      dohorizontal := true;
      horizontalbarwidth  := 1.0;
      horizontalbarheight := 1.0;
      horizontalbarcharacter := '-';
      dovertical := defaultdovertical;
      verticalbarwidth  := 1.0;
      verticalbarheight := 1.0;
      verticalbarcharacter := '|';

   end;
   if aastate = 0 then frameallowed := 0; (* this makes things faster... *)

   printheader := (hopi[1] = 'H') or (hopi[1] = 'B');
   printorgchr := (hopi[2] = 'O');
   printpiece  := (hopi[3] = 'P');
   printindex  := (hopi[4] = 'I');

   featuresOnSameLine := (sof[1] = 'S');
   featuresOnePerLine := (sof[2] = 'O');
   featuresForward    := not (sof[3] = 'R'); (* errors => forward *)

   (* check settable variables *)
   if basesperline <= 0 then begin
      writeln(output,'line lengths must be positive');
      checkout := false;
   end;
   if (aastate < 0) or (aastate > 2) then begin
      write  (output,'amino acid control variable must be');
      writeln(output,' 0, 1 or 2, not ',aastate:1);
      checkout := false;
   end;
   if (frameallowed > 7) or (frameallowed < 0) then begin
      writeln(output,'the frames selected must be between 0 and 7');
      checkout := false;
   end;
   if (codelength <> 1) and (codelength <> 3) then begin
      writeln(output,'Only amino acid codes of',
                     ' length 1 and 3 are available');
      checkout := false;
   end;
   if (seqlines < 0) or (seqlines > 2) then begin
      writeln(output,'only 0 to 2 lines of sequence can be written');
      checkout := false;
   end;
   if not (pageaction in ['c','l','n']) then begin
      writeln(output,'Action for page marks must be one of: c,l,n');
      checkout := false;
   end;
   if pagelength < 2 then begin
      writeln(output,'Page length must be > 1');
      checkout := false;
   end;

   (* convert frameallowed into bits for each frame.
      first preset the booleans to false. *)
   frame0allowed := false;
   frame1allowed := false;
   frame2allowed := false;
   framecalc := frameallowed;
   aalines := 0;
   if framecalc >= 4 then begin
      frame0allowed := true;
      framecalc := framecalc - 4; (* expose next bit *)
      aalines := aalines + 1
   end;
   if framecalc >= 2 then begin
      frame1allowed := true;
      framecalc := framecalc - 2;
      aalines := aalines + 1
   end;
   if framecalc >= 1 then begin
      frame2allowed := true;
      aalines := aalines + 1
   end;

(* 2002 May 1: remove this check to allow pure walkers to be shown.
   if (seqlines=0) and (aalines=0) then begin
      writeln(output,'you must print either sequence or amino acids');
      checkout := false;
   end;
*)

   if aalines <> 0 then if basesperline mod 3 <> 0 then begin
      write(output,'bases per line must be a multiple of 3');
      writeln(output,' when printing amino acids');
      checkout := false;
   end;

   for i := 1 to maxdatacontrol do begin
      if not (ndaf[i] in ['N','A','D','F',
                                 'n','a','d','f']) then begin
         write(output,'data control symbols must be one of "NDAFnadf ",');
         writeln(output,' not "',ndaf[i],'".');
         checkout := false
      end;
   end;

   if (sof[3] <> 'R') and (sof[3] <> 'F') then begin
      writeln(output,'The third character of sof feature position control',
            ' must be F or R');
      writeln(output,'not "',sof[3],'"');
      checkout := false;
   end;

(* Bug fix of 2004 July 31 - scaleimage cannot be zero.
google:
"Top 10 things likely to be overheard if you had a Klingon Programmer"
http://rucus.ru.ac.za/~urban/docs/humour/Klingon%20Programmers.txt
*)
   if scaleimage <= 0.0 then begin
      writeln(output,'scaleimage must be positive');
      checkout := false;
   end;

   if lowerbound > 0 then begin
      writeln(output,'lowerbound must be zero or negative');
      checkout := false;
   end;

   if figurebottom > 0 then begin
      writeln(output,'figurebottom must be zero or negative');
      checkout := false;
   end;

   if shiftsequence >= basesperline then begin
      writeln(output,'shiftsequence (',shiftsequence:1,
                     ') must be less than basesperline (',basesperline:1,')');
      checkout := false;
   end;

   if shiftsequence < 0 then begin
      writeln(output,'shiftsequence (',shiftsequence:1,
                     ' must be zero or positive');
      checkout := false;
   end;

   if not (pageedges in ['d','s']) then begin
      writeln(output,'pageedges',
            ' must be d or s');
      writeln(output,'not "',pageedges,'"');
      checkout := false;
   end;

   (* note: pageboundaries is either 'b' or something else - no checking *)

   if extraright < 0 then begin
      writeln(output,'extraright (',extraright:1,
                     ' must be zero or positive');
      checkout := false;
   end;

   if MinimumLines < 0 then begin
      writeln(output,'minimumLines can not be less than zero');
      checkout := false;
   end;

   if artmode = 'a'
   then writeln(output, '*** artmode is ON - white background ***');

   if artmode = 'b'
   then writeln(output, '*** artmode is ON - black background ***');

   if artmode = 'B'
   then writeln(output, '*** artmode is ON - controlled black background ***');

   if artmode = 'n'
   then writeln(output, '*** artmode is ON except names are given ***');

   if outline = 'o' then begin
      writeln(output, '*** outlining walker letters ***');

      if outlinewidth < 0 then begin
         writeln(output,'outlinewidth can not be less than zero');
         checkout := false;
      end;

      if outlinegray < 0.0 then begin
         writeln(output,'outlinegray can not be less than 0.0');
         checkout := false;
      end;

      if outlinegray > 1.0 then begin
         writeln(output,'outlinegray can not be greater than 1.0');
         checkout := false;
      end;

   end;

   if not checkout then begin
{
      writeln(output,'lister readparameters: final checkout failed');
}
      writeln(output,'lister readparameters: bad parameter(s)');
      halt;
   end;

end;
(* end module readparameters *)

(* begin module writetriplet *)
procedure writetriplet(var a: text; symbol: char);
(* go through cases to get three letter name *)
begin
   case symbol of
      'a': write(a,'a');
      'c': write(a,'c');
      'g': write(a,'g');
      't': write(a,'t');
      'u': write(a,'u');
      'U': write(a,'U');

      'D': write(a,'asp');
      'E': write(a,'glu');
      'N': write(a,'asn');
      'Q': write(a,'gln');
      'K': write(a,'lys');

      'R': write(a,'arg');
      'H': write(a,'his');
      'P': write(a,'pro');
      'T': write(a,'thr');
      'S': write(a,'ser');

      'C': write(a,'cys');
      'A': write(a,'ala');
      'G': write(a,'gly');
      'Y': write(a,'tyr');
      'W': write(a,'trp');

      'F': write(a,'phe');
      'L': write(a,'leu');
      'I': write(a,'ile');
      'M': write(a,'met');
      'V': write(a,'val');

   end;
end;
(* end module writetriplet *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* 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 version = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module lister.startpostscript *)
procedure startpostscript(var a, colors: text;
                          creator: string;
                          title: string;
                          colorlistcontrol: char; fontsize: integer;
                          deltaXcm, deltaYcm, scaleimage: real;
                          llx: real; (* lower left x *)
                          lly: real; (* lower left y *)
                          urx: real; (* upper left x *)
                          ury: real  (* upper left y *)   );
(* start writing postscript for color text lines to file a, using the colors
file for color definitions.  Fonts are set to fontsize (in points, 72
points/inch).  deltaXcm and deltaYcm determine how much to move the image on
the page.  scaleimage is the scaling factor from the upper left hand corner *)
const
   symbolmax = 26; (* number of color symbols allowed *)
   (* list of the DNA and protein
      symbols.  The 0 position is the stop codon. *)
{ the sun compiler objects to indexing into this:
   symbollist = '.ACDEFGHIKLMNPQRSTVWYacgtuU';
}
   edge = 1; (* points around black background of artwork for safety *)
var
   done: boolean; (* done searching for a symbol? *)
   i: 0..symbolmax; (* index to the name n, index to symbollist and symbolfound *)
   red,green,blue: real; (* colors *)
   symbol: char; (* one of the bases *)
   symbollist: packed array[0..symbolmax] of char; (* list of the DNA and protein
      symbols.  The 0 position is the stop codon. *)
   symbolfound: packed array[0..symbolmax] of boolean; (* which of symbollist
       were found in the colors file *)
begin
   postscriptheader(a, title, creator, llx, lly, urx, ury);

   writeln(a,'/cmfactor 72 2.54 div def % defines points -> centimeters');
   writeln(a,'/cm { cmfactor mul} def % defines centimeters');
   writeln(a,'/edgecontrol (',edgecontrol,') def');
   writeln(a,'/edgeleft  ',edgeleft: pwid:pdec,' cm def');
   writeln(a,'/edgeright ',edgeright:pwid:pdec,' cm def');
   writeln(a,'/edgelow   ',edgelow:  pwid:pdec,' cm def');
   writeln(a,'/edgehigh  ',edgehigh: pwid:pdec,' cm def');

   (* artmode black *)
{zzzqqq}
{ example from s38 cover figure:
50  50 moveto
600   50 lineto
600 800 lineto
50 800 lineto
closepath
0 0 0 setrgbcolor
fill
}

   if artmode = 'b' then begin
      writeln(a,round(llx-edge):1, ' ', round(lly-edge):1, ' moveto');
      writeln(a,round(urx+edge):1, ' ', round(lly-edge):1, ' lineto');
      writeln(a,round(urx+edge):1, ' ', round(ury+edge):1, ' lineto');
      writeln(a,round(llx-edge):1, ' ', round(ury+edge):1, ' lineto');
      writeln(a,'closepath');
      writeln(a,'0 0 0 setrgbcolor');
      writeln(a,'fill');
   end;

   if artmode = 'B' then begin (* controlled black background *)
      writeln(a,round(llx-edgeleft):1, ' ', round(lly-edgelow):1, ' moveto');
      writeln(a,round(urx+edgeright):1, ' ', round(lly-edgelow):1, ' lineto');
      writeln(a,round(urx+edgeright):1, ' ', round(ury+edgehigh):1, ' lineto');
      writeln(a,round(llx-edgeleft):1, ' ', round(ury+edgehigh):1, ' lineto');
      writeln(a,'closepath');
      writeln(a,'0 0 0 setrgbcolor');
      writeln(a,'fill');
   end;

   writeln(a);
   writeln(a,'% based on typefaces program from page 40 of the Blue book');
   writeln(a);
   writeln(a,'% variables');
   writeln(a,'/fontsize ',fontsize:1,' def');
   writeln(a,'/thefont /Courier-Bold def');
   writeln(a,'% set the font');
   writeln(a,'thefont findfont fontsize scalefont setfont');

   writeln(a);
   writeln(a,'/lineseparation fontsize def');
   writeln(a,'/charwidth % rightward movement between characters');
   writeln(a,'   0 0 moveto');
   writeln(a,'   currentpoint pop ( ) show currentpoint pop exch sub');
   writeln(a,'def');
   writeln(a,'% (charwidth = ) = charwidth =');
   writeln(a,'% check that this value is the same as the default value');
   writeln(a,'% used in the lister program');
   writeln(a,'/defcharacterratio ',defcharacterratio:pwid:pdec,' def');
   writeln(a,'/characterratio charwidth fontsize div def');
   writeln(a,'/tolerateratio ',tolerateratio:pwid,
                         ' def % accuracy to compare the above two');
   writeln(a,'   characterratio tolerateratio mul round % dup =');
   writeln(a,'defcharacterratio tolerateratio mul round % dup =');
   writeln(a,'ne');
   writeln(a,'{');
   if writecharwidthmessage then begin
      writeln(a,' (To function properly, this program needs the width to) =');

      writeln(a,' (height ratio of the characters.',
                '  PostScript measures this:) =');
      writeln(a,' (charwidth/fontsize= )',
                ' = charwidth fontsize div =');
      writeln(a,' (but defcharacterratio = )',
                ' = defcharacterratio =');
      writeln(a,' (The program will use the measured ratio) = flush');
   end;
   writeln(a,' /defcharacterratio characterratio def');
   writeln(a,'} if');

   writeln(a,'/charwidth2m charwidth 2 mul def');
   writeln(a,'/charwidth2d charwidth 2 div def');
   writeln(a,'/charwidth2mneg charwidth2m neg def');
   writeln(a,'/charwidth2dneg charwidth2d neg def');

   writeln(a);
   (* put upper left comfortably away from the limit: *)
   writeln(a,'/deltaXcm ',deltaXcm:10:5,' cm def');
   writeln(a,'/deltaYcm ',deltaYcm:10:5,' cm def');
   writeln(a,'/scaleimage ',scaleimage:10:5,' def');

   writeln(a,'/n { % start new line');
   writeln(a,'/currenty currenty lineseparation sub def');

   writeln(a,'0 currenty moveto} def');
   writeln(a,'/s {show} def');
   writeln(a,'/sn {s n} def');
   writeln(a);

   if pageboundaries = 'b' then begin
      writeln(a);
      makepageedges(a);
   end;

   writeln(a,'/startpage{');

   (* new postion for gsave: *)
   writeln(a,'gsave % allows embedding entire figure');

   if pageboundaries = 'b' then writeln(a,'makepageedges');

   (* The code here must match the compensating code at RRR *)
   if colorlistcontrol = 'R'
   then begin
      (* undo the edgecontrol *)
      (*         R1----------     R2---------- *)
      writeln(a,'llx edgehigh add lly edgeleft add translate');
      writeln(a,'90 rotate');
   end
   else begin (* colorlistcontrol = 'C' *)
      (*         C1----------     C2---------- *)
      writeln(a,'llx edgeleft add ury edgehigh sub translate');
   end;

   (* when we are in the default page mode, shift now *)
   if pageedges = 'd'
   then writeln(a,'deltaXcm deltaYcm translate');

   writeln(a,'scaleimage dup scale');
   writeln(a,'/currenty 0 def');
   writeln(a,'0 0 moveto');
   writeln(a,'n % move one line onto the page!');

{ 2006 oct 26 original position
   writeln(a,'gsave % allows embedding entire figure');
}
   writeln(a,'} def');

   writeln(a,'/endpage{');
   writeln(a,'grestore % allows embedding entire figure');
   writeln(a,'showpage');
   writeln(a,'} def');

   writeln(a);
{
   The GPC compiler objects to this:
   symbollist := '.ACDEFGHIKLMNPQRSTVWYacgtuU';

   "only Pascal string type, array of char, and char type
   are assignment compatible with a string"
}
   symbollist[ 0] := '.';
   symbollist[ 1] := 'A';
   symbollist[ 2] := 'C';
   symbollist[ 3] := 'D';
   symbollist[ 4] := 'E';
   symbollist[ 5] := 'F';
   symbollist[ 6] := 'G';
   symbollist[ 7] := 'H';
   symbollist[ 8] := 'I';
   symbollist[ 9] := 'K';
   symbollist[10] := 'L';
   symbollist[11] := 'M';
   symbollist[12] := 'N';
   symbollist[13] := 'P';
   symbollist[14] := 'Q';
   symbollist[15] := 'R';
   symbollist[16] := 'S';
   symbollist[17] := 'T';
   symbollist[18] := 'V';
   symbollist[19] := 'W';
   symbollist[20] := 'Y';
   symbollist[21] := 'a';
   symbollist[22] := 'c';
   symbollist[23] := 'g';
   symbollist[24] := 't';
   symbollist[25] := 'u';
   symbollist[26] := 'U';

   for i := 0 to symbolmax do begin
      symbolfound[i] := false;
   end;

   (* set up the color statements *)
   (* make a dictionary with symbolmax+1 slots *)
   writeln(a,'/colordictionary ',(symbolmax+1):1,' dict def');
   reset(colors);
   while not eof(colors) do begin
      while eoln(colors) do readln(colors);
      if not eof(colors) then begin
         if colors^ <> '*' then begin (* skip comment lines *)
            (* implement the backslash protection scheme: *)
            if colors^ = '\' then get(colors);
            read(colors,symbol,red,green,blue);

            i := 0;
            done := false;
            while not done do begin
               if symbol = symbollist[i] then begin
                  if symbolfound[i] then begin
                     writeln(output,'There are two definitions',
                                    ' in the colors file for symbol "',
                                    symbol,'"');
                     halt
                  end;
                  symbolfound[i] := true;
                  done := true
               end
               else begin
                  i := succ(i);
                  if i > symbolmax then begin
{
                     writeln(output,'color symbol "',symbol,'"',
                     ' is not in the set "',symbollist,'"');
}
                     writeln(output,'color symbol "',symbol,'"',
                     ' is not in the set "');
                     for i := 1 to symbolmax
                     do write(output, symbollist[i]);
                     writeln(output,'"');
                     halt
                  end
               end
            end;

            write(a,'colordictionary (');
            protectpostscript(a,symbol);
            write(a,symbol);
            write(a,')');

            write(a,' {');
            if (red = 1.0) or (red = 0.0)
            then write(a,round(red):1)
            else write(a,red:pwid:pdecolor);

            write(a,' ');
            if (green = 1.0) or (green = 0.0)
            then write(a,round(green):1)
            else write(a,green:pwid:pdecolor);

            write(a,' ');
            if (blue = 1.0) or (blue = 0.0)
            then write(a,round(blue):1)
            else write(a,blue:pwid:pdecolor);

            write(a,' setrgbcolor');

            writeln(a,'} put');

         end;
         readln(colors)
      end
   end;

   for i := 0 to symbolmax do begin
      if not symbolfound[i] then begin
         writeln(a,'colordictionary (',symbollist[i],')',
                   ' {0 0 0 setrgbcolor}',
                   ' put');
      end;
   end;

   for i := 0 to symbolmax do begin
      if (symbollist[i] in ['.','a','c','g','t']) or (codelength = 1)
      then begin (* single letter amino acid letter method *)
        writeln(a,'/',symbollist[i],
               ' {colordictionary (',symbollist[i],
               ') get exec',
               ' (',symbollist[i],') s',
               '} def')
      end
      else begin (* triple letter amino acid letter method *)
         write(a,'/');
         writetriplet(a,symbollist[i]);
         write(a,' {colordictionary (',
                 symbollist[i],
                 ') get exec (');
         writetriplet(a,symbollist[i]);
         writeln(a, ') s} def')
      end;
   end;

   writeln(a,'/amb {1 0 0 setrgbcolor (amb) s} def'); (* set red *)
   writeln(a,'/och {1 0 0 setrgbcolor (och) s} def'); (* set red *)
   writeln(a,'/opa {1 0 0 setrgbcolor (opa) s} def'); (* set red *)

   writeln(a,'/b {0 0 0 setrgbcolor} def');  (* set black *)
   writeln(a,'/e {( ) s} def');  (* make empty space *)

(*
   This was never used!!!
   writeln(a,'/ee {% number ee -. make many double spaces');
   writeln(a,' /spaces exch def');
   writeln(a,' 1 1 spaces {e e} for');
   writeln(a,'} def');

   writeln(a,'/mb {% number mb -. make multible blanks');
   writeln(a,' /spaces exch def');
   writeln(a,' 1 1 spaces {e} for');
   writeln(a,'} def');
*)

   writeln(a,'/MB {% number MB -. make Multible Blanks');
   writeln(a,' /spaces exch def');

   (* The for loop leaves the count on the stack.
      Adding a pop removes the counts. *)
   writeln(a,' 1 1 spaces {pop ( ) show} for');
   writeln(a,'} def');

   writeln(a);
   writeln(a,'/lowerbound ',lowerbound:pwid, ' def % lower bound in bits');
   writeln(a,'/upperbound ',upperbound:pwid, ' def % upper bound in bits');
   writeln(a,'/figurebottom ',figurebottom:pwid, ' def % lower bound of',
             ' walker in lines (=bits)');
   writeln(a,'/basesperline ',basesperline:1,' def % width of page in bases');
   writeln(a,'/pagecharacters basesperline 2 mul def % characters across page');

   writeln(a);
   writeln(a,'/hline { % thewidth hline - ;',
             ' produce a horizontal line of thewidth');
   writeln(a,'gsave');
   writeln(a,'  /thewidth exch def');
   writeln(a,'  currentpoint newpath moveto b');
   writeln(a,'  0.5 setlinewidth');
   writeln(a,'  charwidth thewidth mul 0 rlineto stroke');
   writeln(a,'grestore');
   writeln(a,'} def');

   writeln(a);
   writeln(a,'/str 20 string def');
   writeln(a,'/hlines { % multiwidth hline - ;',
             ' produce horizontal lines of multiwidth');
   writeln(a,'gsave');
   writeln(a,'  /multiwidth exch def');
   writeln(a,'  0 lineseparation figurebottom mul rmoveto');
   writeln(a,'  figurebottom 1 2 {');
   writeln(a,'    gsave');
   writeln(a,'      multiwidth 1 gt {');
   writeln(a,'        -5 charwidth mul 0 rmoveto % move backwards');
   writeln(a,'        dup 0 lt {(-)} {(+)} ifelse s % capture sign');
   writeln(a,'        abs str cvs s ( bits ) s % show absolute bits');
   writeln(a,'      } if');
   writeln(a,'      multiwidth -1 eq {');
   writeln(a,'        pop charwidth2mneg 0 rmoveto 2 hline');
   writeln(a,'      }');
   writeln(a,'      {multiwidth hline} % draw the line');
   writeln(a,'      ifelse');
   writeln(a,'    grestore');
   writeln(a,'    0 lineseparation rmoveto} for');
   writeln(a,'grestore');
   writeln(a,'} def');

   (* define colors for color bar *)
   writeln(a,'/pink     {1   0.2 1   sethsbcolor} def');
   writeln(a,'/greenish {0.4 0.2 1   sethsbcolor} def');
   writeln(a,'/purple   {1   0   1   setrgbcolor} def');
   writeln(a,'/black    {0   0   0   sethsbcolor} def');
   (* define down box colors.  These can be redefined in the marks file.
      This probably only should be done to get gray for black and white
      figures. *)
   writeln(a,'/downblack {black} def');
   writeln(a,'/downpurple {purple} def');

   writeln(a,'/cmperbit ',cmperbit:pwid:pdec,' cm def % cm per bit');

   writeln(a,'/ncharwidth2m charwidth2m neg def % negative of charwidth2m');
   writeln(a,'/bitspercm 1 cmperbit div def');
   writeln(a,'/charupper upperbound bitspercm div def',
             ' % upper bound of characters');
   writeln(a,'/charlower lowerbound bitspercm div def',
             ' % lower bound of characters');
   writeln(a,'/charrange charupper charlower sub def',
             ' % total height of character box');


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

(* 2004 July 13.  Implement a rectangle that is around (and under) each
letter of the walker.  Control the edge color and the fill color.
Control which edges get shown. *)

   writeln(a);
   writeln(a,'/doline { % x y switch doline -');
   writeln(a,'% do an rlineto or rmoveto depending on the switch');
   writeln(a,'% 0 = off, 1 = on');
   writeln(a,'/dolineswitch exch def');
   writeln(a,'/doliney exch def');
   writeln(a,'/dolinex exch def');
   writeln(a,'  currentpoint translate');
   writeln(a,'  0 0 moveto');
   writeln(a,'dolineswitch 1 eq');
   writeln(a,'{');
   writeln(a,'  dolinex doliney rlineto');
   writeln(a,'}');
   writeln(a,'{');
   writeln(a,'  dolinex doliney rmoveto');
   writeln(a,'}');
   writeln(a,'ifelse');
   writeln(a,'} def');

   writeln(a);
   writeln(a,'/setthecolor { % [type] setthecolor -');
   writeln(a,'% select hsb or rgb color');
   writeln(a,'colorkind (h) eq');
   writeln(a,'{sethsbcolor}');
   writeln(a,'{setrgbcolor}');
   writeln(a,'ifelse');
   writeln(a,'} def');

   writeln(a);
   writeln(a,'/makerectangle { % el c eh es eb fh fs fb th l r t b');
   writeln(a,'                 % makerectangle');
   writeln(a,'% make a colored rectangle at the walker letter');
   writeln(a,'% the parameters are:');

   writeln(a,'% el = edgelinewidth: edge linewidth');
   writeln(a,'% c = color kind: how color is defined: r for RGB, h for HSB');
   writeln(a,'% eh = edgeh: edge hue        OR red   - for color');
   writeln(a,'% es = edges: edge saturation OR blue  - for color');
   writeln(a,'% eb = edgeb: edge brightness OR green - for color');
   writeln(a,'% fh = fillh: fill hue        OR red   - for color');
   writeln(a,'% fs = fills: fill saturation OR blue  - for color');
   writeln(a,'% fb = fillb: fill brightness OR green - for color');
   writeln(a,'% th = petalY: petal thickness vertically');
   writeln(a,'%      (not relevant to sequence walker )');
   writeln(a,'% l = left   edge 0 = off, 1 = on');
   writeln(a,'% r = right  edge 0 = off, 1 = on');
   writeln(a,'% t = top    edge 0 = off, 1 = on');
   writeln(a,'% b = bottom edge 0 = off, 1 = on');

   writeln(a,'/bottomedge exch def');
   writeln(a,'/topedge exch def');
   writeln(a,'/rightedge exch def');
   writeln(a,'/leftedge exch def');
   writeln(a,'/petalY exch def');      (* seems to be unnecessary??? *)
   writeln(a,'/fillb exch def');
   writeln(a,'/fills exch def');
   writeln(a,'/fillh exch def');
   writeln(a,'/edgeb exch def');
   writeln(a,'/edges exch def');
   writeln(a,'/edgeh exch def');
   writeln(a,'/colorkind exch def');
   writeln(a,'/edgelinewidth exch def');

   writeln(a,'gsave');
   writeln(a,'  charwidth2dneg 0 rmoveto');
   writeln(a,'  currentpoint translate');
(* draw central line - not desired
   writeln(a,'  0 0 moveto');
   writeln(a,'  charwidth2m 0 rlineto');
   writeln(a,'  ncharwidth2m 0 rlineto');
   writeln(a,'  0 charlower rlineto');
*)

   (* new fill method: *)
   writeln(a,'  0 charlower moveto');
   writeln(a,'  charwidth2m 0    rlineto');
   writeln(a,'  0 charrange      rlineto');
   writeln(a,'  ncharwidth2m 0   rlineto');
   writeln(a,'  closepath');
   writeln(a,'  clip'); (* make sure the fill is entirely inside the box *)
   writeln(a,'  fillh fills fillb setthecolor');
   writeln(a,'  fill');

   (* new line edges done separately: *)
   writeln(a,'  edgelinewidth 0 ge {'); (* edge control; 2005 Dec 22 *)
   writeln(a,'    0 charlower moveto');
   writeln(a,'    charwidth2m  0 bottomedge doline');
   writeln(a,'    0 charrange     rightedge doline');
   writeln(a,'    ncharwidth2m 0    topedge doline');
   writeln(a,'    0 charrange neg  leftedge doline'); (* altered *)
   writeln(a,'    edgeh edges edgeb setthecolor');
   writeln(a,'    edgelinewidth setlinewidth');
{2006 Jun 07: REMOVE the clip - it WILL be inside
   writeln(a,'    clip');
}
   writeln(a,'    stroke');
   writeln(a,'  } if');

   writeln(a,'grestore');
   writeln(a,'} bind def');

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

   writeln(a);
   writeln(a,'/makebar { % make a bar');
   writeln(a,'gsave');
   writeln(a,'  charwidth2dneg 0 rmoveto');
   writeln(a,'  currentpoint translate');
(* draw central line - not desired
   writeln(a,'  0 0 moveto');
   writeln(a,'  charwidth2m 0 rlineto');
   writeln(a,'  ncharwidth2m 0 rlineto');
   writeln(a,'  0 charlower rlineto');
*)
   writeln(a,'  0 charlower moveto');
   writeln(a,'  charwidth2m 0 rlineto');
   writeln(a,'  0 charrange rlineto');
   writeln(a,'  ncharwidth2m 0 rlineto');
   writeln(a,'  closepath');
   writeln(a,'  gsave fill grestore');
   writeln(a,'  clip 0 setgray stroke');
   writeln(a,'grestore');
   writeln(a,'} bind def');

(*
   I can use this to override makebar, for testing only:
   writeln(a);
   writeln(a,'/makebar { % make a bar');
   writeln(a,'1  0.8 1 1   0.7 0.2 1 1  0 1 0 0 makerectangle');
   writeln(a,'} bind def');
*)

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

   writeln(a);
   writeln(a,'/makedownbar { % make a bar that only goes down');
   writeln(a,'gsave');
   writeln(a,'  charwidth2dneg 0 rmoveto');
   writeln(a,'  currentpoint translate');
   writeln(a,'  0 0 moveto');
   writeln(a,'  0 charlower rlineto');
   writeln(a,'  charwidth2m 0 rlineto');
   writeln(a,'  0 charlower neg rlineto');
   writeln(a,'  closepath');
   writeln(a,'  gsave fill grestore');
   writeln(a,'  clip stroke');
   writeln(a,'grestore');
   writeln(a,'} bind def');

writeln(a,'%/makedownbar { } def % this allows blocking the function');

   writeln(a);
   writeln(a,'/clipdown { % clip downward drawn characters');
   writeln(a,'  charwidth2dneg 0 rmoveto');
   writeln(a,'  currentpoint translate');
   writeln(a,'  0 0 moveto');
   writeln(a,'  0 charlower rlineto');
   writeln(a,'  charwidth2m 0 rlineto');
   writeln(a,'  0 charlower neg rlineto');
   writeln(a,'  closepath');
   writeln(a,'  clip');
   writeln(a,'  % restore previous location');
   writeln(a,'  charwidth2dneg neg 0 rmoveto');
   writeln(a,'  currentpoint translate');
   writeln(a,'} bind def');

writeln(a,'%/clipdown { } def % this allows blocking the function');

   writeln(a);
   marksymbols(a);

   writeln(a);
   (* define method for stepping by single characters for use
      in putting out the marks *)
   writeln(map,'/mm {e currentpoint translate} def % step 1 character');
   writeln(map,'/m2 {e e currentpoint translate} def % step 2 characters');
   writeln(map,'/mh {charwidth2d 0 rmoveto currentpoint translate}',
                 ' def % step half character');
   writeln(a);

   (* define italics: "\) \( E. coli \) IT \("
      Code taken from makelogo.p *)

   writeln(a);
   writeln(a,'% define fonts');
   writeln(a,'/ffss {findfont fontsize scalefont setfont} def');
   writeln(a,'/FontForStringRegular {thefont           ffss} def');
   writeln(a,'/FontForStringItalic  {/Times-BoldItalic ffss} def');
(*
   THE APPLE laserWriter 16/600PS PRINTER CANNOT HANDLE THIS:
   writeln(a,'/FontForStringItalic  {/Courier-BoldItalic ffss} def');
*)
   writeln(a,'/FontForLogo          {/Helvetica-Bold   ffss} def');
   writeln(a,'/FontForPrime         {/Symbol           ffss} def');
   writeln(a,'/FontForSymbol        {/Symbol           ffss} def');

   writeln(a);
   writeln(a,'% make italics possible in quotestrings');
   writeln(a,'/IT {% TRstring ITstring IT -');
   writeln(a,'  exch show');
   writeln(a,'  FontForStringItalic');
   writeln(a,'  show');
   writeln(a,'  FontForStringRegular');
   writeln(a,'} def');

   writeln(a);
   writeln(a,'% make symbols possible in quotestrings');
   writeln(a,'/SY {% TRstring SYstring SY -');
   writeln(a,'  exch show');
   writeln(a,'  FontForSymbol');
   writeln(a,'  show');
   writeln(a,'  FontForStringRegular');
   writeln(a,'} def');

   writeln(a);

{ooo}
   (* default outline parameters *)
   if outline = 'o'
   then writeln(a,'/outline true def')
   else writeln(a,'/outline false def');
   writeln(a,'/outlinewidth ',outlinewidth:pwid:pdec,' def');
   writeln(a,'/outlinegray  ',outlinegray :pwid:pdec,' def');

end;
(* modified from version = 5.46; (@ of alist.p 1996 January 17 *)
(* end module lister.startpostscript *)

(* 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 = 5.88; (@ of prgmod.p 2022 Dec 20 *)

(* begin module characterinbox *)
procedure characterinbox(var a: text);
(* write out a postscript procedure that allow
one to put a character inside a defined box.
The form is:
    5 cm 10 cm (G) 90 boxshow
where
* cm has been already defined elsewhere
to convert from cm to points,
* 5 cm is the x size (in points)
* 10 cm is the y size (in points)
* G is the character
* 90 is the angle to rotate the character inside the box.
The angle can only be -90, 0, 90, or 180.
*)
begin
writeln(a);
writeln(a,'/setthelinewidth {1 setlinewidth} def');
writeln(a,'setthelinewidth % set to normal linewidth');
writeln(a);
writeln(a,'/charparams { % char charparams => uy ux ly lx');
writeln(a,'% takes a single character and returns the coordinates that');
writeln(a,'% defines the outer bounds of where the ink goes');
writeln(a,'  gsave');
writeln(a,'    newpath');
writeln(a,'    0 0 moveto');
writeln(a,'    % take the character off the stack and use it here:');
writeln(a,'    true charpath');
writeln(a,'    flattenpath');
writeln(a,'    pathbbox % compute bounding box of 1 pt. char => lx ly ux uy');
writeln(a,'    % the path is here, but toss it away ...');
writeln(a,'  grestore');
writeln(a,'  /uy exch def');
writeln(a,'  /ux exch def');
writeln(a,'  /ly exch def');
writeln(a,'  /lx exch def');
writeln(a,'} bind def');
writeln(a);
writeln(a,'/dashbox { % xsize ysize dashbox -');
writeln(a,'% draw a dashed box of xsize by ysize (in points)');
writeln(a,'  /ysize exch def % the y size of the box');
writeln(a,'  /xsize exch def % the x size of the box');
writeln(a,'  1 setlinewidth');
writeln(a,'  gsave');
writeln(a,'    0 0 0 setrgbcolor'); (* force it black *)
writeln(a,'    % Define the width of the dashed lines for boxes:');
writeln(a,'    newpath');
writeln(a,'    0 0 moveto');
writeln(a,'    xsize 0 lineto');
writeln(a,'    xsize ysize lineto');
writeln(a,'    0 ysize lineto');
writeln(a,'    0 0 lineto');
writeln(a,'    [3] 0 setdash');
writeln(a,'    stroke');
writeln(a,'  grestore');
writeln(a,'  setthelinewidth');
writeln(a,'} bind def');
writeln(a);
writeln(a,'/swapxy {% switch the values of xsize and ysize');
writeln(a,'  /holdsize xsize def');
writeln(a,'  /xsize ysize def');
writeln(a,'  /ysize holdsize def');
writeln(a,'} bind def');
writeln(a);
writeln(a,'/boxshow { % xsize ysize char charangle down boxshow');
writeln(a,'% show the character char with a box around it, sizes in points');
writeln(a,'% the character angle can only be -90, 0, +90 or +180');
writeln(a,'% NB: negative y size no longer means rotate +180');
writeln(a,'% if down is true, the character is drawn down and to the right');
writeln(a,'% otherwise, the character is drawn up and to the right');

writeln(a,'% 2006 Sep 14: Ghostview now (?) has a limitation on');
writeln(a,'% the scaling of characters.  If xmulfactor');
writeln(a,'% is 0.00677774, then when the scale is applied,');
writeln(a,'% charparams crashes with a limitcheck at " true charpath".');
writeln(a,'% To resolve this, if xmulfactor is less than 0.007');
writeln(a,'% it is set to 0.02 (this value was determined empirically).');

writeln(a,'gsave');
writeln(a,'  /down exch def % draw character below or above line');
writeln(a,'  /charangle exch def % angle to rotate the character');
writeln(a,'  /tc exch def % define the character');
writeln(a,'  /ysize exch abs def % the y size of the character');
writeln(a,'  /xsize exch abs def % the x size of the character');
writeln(a,'  /xmulfactor 1 def /ymulfactor 1 def');
writeln(a,'  currentpoint translate');
writeln(a);

writeln(a,'  charangle 180 eq {');
writeln(a,'    down {0 ysize neg translate} if');
writeln(a,'    xsize ysize translate');
writeln(a,'    180 rotate');
writeln(a,'  } if');

writeln(a,'  charangle 90 eq {');
writeln(a,'    down {0 ysize neg translate} if');
writeln(a,'    xsize 0 translate');
writeln(a,'    90 rotate');
writeln(a,'    swapxy');
writeln(a,'  } if');

writeln(a,'  charangle -90 eq {');
writeln(a,'    down not {0 ysize translate} if');
writeln(a,'    -90 rotate');
writeln(a,'    swapxy');
writeln(a,'  } if');

writeln(a);
writeln(a,'  xsize 0 ne  ysize 0 ne  and {'); (* protection *)
writeln(a,'    showingbox {xsize ysize dashbox} if');
writeln(a,'    2 {');
writeln(a,'      gsave');
writeln(a,'      xmulfactor ymulfactor scale');
writeln(a,'      tc charparams');
writeln(a,'      grestore');
writeln(a);
writeln(a,'      ysize % desired size of character in points');
writeln(a,'      uy ly sub % height of character in points');
writeln(a,'      dup 0.0 ne {');
writeln(a,'        div % factor by which to scale up the character');
writeln(a,'        /ymulfactor exch def');
writeln(a,'      } % end if');
writeln(a,'      {pop pop}');
writeln(a,'      ifelse');
writeln(a);
writeln(a,'      xsize % desired size of character in points');
writeln(a,'      ux lx sub % width of character in points');
writeln(a,'      dup 0.0 ne {');
writeln(a,'        div % factor by which to scale up the character');
writeln(a,'        /xmulfactor exch def');

writeln(a,'        % 2006 Sep 14 threshold adjustment:');
writeln(a,'        xmulfactor 0.007 lt { /xmulfactor 0.02 def } if');

writeln(a,'      } % end if');
writeln(a,'      {pop pop}');
writeln(a,'      ifelse');
writeln(a,'    } repeat');
writeln(a);
writeln(a,'    % Adjust horizontal position if the symbol is an I');
writeln(a,'    tc (I) eq {charwidth 2 div % half of requested character width');
writeln(a,'               ux lx sub 2 div % half of the actual character');
writeln(a,'                  sub      0 translate} if');
writeln(a,'    % Avoid x scaling for I');
writeln(a,'    tc (I) eq {/xmulfactor 1 def} if');
writeln(a);
writeln(a,'    /xmove xmulfactor lx mul neg def');
writeln(a,'    /ymove ymulfactor ly mul neg def');
writeln(a);
writeln(a,'    newpath');
writeln(a,'    xmove ymove moveto');
writeln(a,'    xmulfactor ymulfactor scale');
writeln(a);
{
writeln(a,'    tc show');
}


{ooo}
(* The boxshow function in makelogo has diverged from that in lister.
They do somewhat different things though makelogo does have an outline
function.  In makelogo there is an 'outline' global but no control of
width or color.  Those are needed for lister.  Also, the center of the
character in makelogo is white but here it must allow the background
petal to show up.
---
In boxshow use three globals,
outline outlinewidth outlinegray
*)
writeln(a,'    outline { % OUTLINE of characters');
writeln(a,'      gsave');
{ bug 2006 May 09: incorrect outline in PDF documents!
writeln(a,'        tc show');
}
writeln(a,'        tc true charpath fill'); (* corrected bug! *)
writeln(a,'      grestore');
writeln(a,'      gsave');
writeln(a,'        tc true charpath');
writeln(a,'        clip');
writeln(a,'        outlinewidth setlinewidth');
writeln(a,'        outlinegray setgray');
writeln(a,'        stroke');
writeln(a,'      grestore');
writeln(a,'      }');
writeln(a,'      { % regular characters');
writeln(a,'        tc show');
writeln(a,'      }');
writeln(a,'    ifelse');
{
% *************************************************************************
% OUTLINE of characters
%
% SOLUTION:  The charpath is not the same for
%
%   (a) show
% and
%   (a) true charpath fill
%
% THE LATTER WORKS CORRECTLY!
%
% The reason is that this way exactly the same character path is used
% for both the stroke and the fill.
%
% This works fine with all three viewers:
% Ghostview (3.5.8)
% Acrobat Reader (7.0.1, www.adobe.com)
% xpdf (2.00, http://www.foolabs.com/xpdf)
%
% The charpath function is described in:
% PostScript Language Reference Manual,
% Second edition, page 372
%
% See the outline.eps program for further details
% *************************************************************************
}

writeln(a,'  } if');
writeln(a,'grestore');
writeln(a,'} bind def');
writeln(a);
writeln(a,'/showingbox false def');
writeln(a);
end;

(* end module characterinbox *)

(* begin module writeps *)
procedure writeps(var fromfile, tofile: text; line: linetype);
(* write PostScript from one file to another *)
var
   devnull: text; (* /dev/null: a "nowhere" to dump the data *)
begin
   reset(fromfile);
   rewrite(devnull);
   while not eof(fromfile) do begin
      write(tofile,'(');
      while not eoln(fromfile) do begin
         tofile^ := fromfile^;
         put(tofile);
         get(fromfile)
      end;
      readln(fromfile);
      write(tofile,') s '); (* nextline will do the ln *)
      nextline(devnull,tofile,mapcontrol,true,
            linenumber,pagenumber,basesperline, dummy,
                              line);
   end;
end;
(* end module writeps *)

(* begin module writeparameters *)
procedure writeparameters(var headerfile: text);
(* write the global parameters to the header file *)
var
   p: ptrigptr; (* current pointer to the page trigger list *)
begin
   (* tell the user the settings *)
   writeln(headerfile,'* ',basesperline:5,' basesperline');

   write(headerfile,'* ',aastate:5,' aastate: amino acid listing mode (');
   case aastate of
      0: writeln(headerfile,'no amino acids)');
      1: writeln(headerfile,'potential peptides)');
      2: writeln(headerfile,'all peptides)');
   end;

   write(headerfile,'* ',frameallowed:5,' frameallowed (');
   if frameallowed = 0 then write(headerfile,'no ');
   if frame0allowed    then write(headerfile,'top ');
   if frame1allowed    then write(headerfile,'middle ');
   if frame2allowed    then write(headerfile,'bottom ');
   write(headerfile,'frame');
   if (frameallowed = 1) or
      (frameallowed = 2) or
      (frameallowed = 4) then writeln(headerfile,' is on)')
                         else writeln(headerfile,'s are on)');

   writeln(headerfile,'* ',codelength:5,' codelength:',
                      ' letters per amino acid symbol');

   write(headerfile,'* ',seqlines:5,' seqlines: strand');
   if seqlines <> 1 then write(headerfile,'s');
   writeln(headerfile,' of sequence printed');
   write  (headerfile,'* ',pageaction:5,' pageaction:');
   case pageaction of
      'c': writeln(headerfile,'computer defined page jump symbol');
      'l': writeln(headerfile,'LaTeX');
      'n': writeln(headerfile,'no page jumps');
   end;
   writeln(headerfile,'* ',pagelength:5,' pagelength');

   writeln(headerfile,'* ',hopi:5,' hopi: Header, Organism/chromosome,',
                         ' Piece, Index');

   writeln(headerfile,'* ',nkfc:5,' nkfc: piece #, key, full, coordinates');

   writeln(headerfile,'* ',ndaf:5,' ndaf: Numbering, DNA,',
                         ' Amino acids, Features');

   writeln(headerfile,'* ',sof:5,' sof: feature position, S=on SAME line,',
                         ' O=ONE per line, FORWARD/REVERSE');

   writeln(headerfile,'* ',pagetrigger:5,' pocld: pagetrigger,',
                         ' piece, organism, chromosome, list,',
                         ' double');
   if decapitalize(pagetrigger) = 'l' then begin
      write(headerfile,'* ');
      p := ptrigs;
      while p <> nil do begin
         write(headerfile,' ',p^.trigger:1);
         p := p^.next;
      end;
      writeln(headerfile);
      linenumber:=linenumber + 1;
   end;

   writeln(headerfile,'* ',colorlistcontrol:5,
                       ' ',fontsize:1,
      ' mapcontrol: C=do map, R= rotate, char height (72 points/inch)');

   writeln(headerfile,'* ',deltaXcm:pwid:pdec,
                      ' ',deltaYcm:pwid:pdec,
                      ' ',scaleimage:pwid:pdec,
                      ' amount to move image in x and y (cm) and scale factor');

   writeln(headerfile,'* ',lowerbound:pwid, ' lowerbound bits');
   writeln(headerfile,'* ',figurebottom:pwid, ' figurebottom bits');

   writeln(headerfile,'* ',shiftsequence:pwid,
      ' shiftsequence (bases) amount to shift the sequence to the right');

   writeln(headerfile,'* ',pageedges,pageboundaries,
      ' ',extraright:pwid,
      ' pageedges: d(default), s(shrinkwrap); pageboundaries (b/n);',
      ' extraright (integer)');

   if KeepDuplicates
   then write(headerfile,'* ')
   else write(headerfile,'* do not');
   writeln(headerfile,' keep duplicate features');

   if Sideways
   then write(headerfile,'* ')
   else write(headerfile,'* do not do');
   writeln(headerfile,' sideways walkers');

   writeln(headerfile,'* ',MinimumLines:pwid,
                      ' Minimum Lines between sequences');

   writeln(headerfile,'* ',artmode, ' ':(pwid-1),
                      'artmode: a(rtmode), b/B(lack), n(ames), otherwise normal.');

   writeln(headerfile);
   linenumber:=linenumber + 20;
end;
(* end module writeparameters *)

(* begin module usermarkstopreamble *)
procedure usermarkstopreamble;
(* Copy the user postscript definitions to the preamble of the postscript
file so that later pages have it available.  This prevents ghostview from
bombing and allows printers to print things like lister waves on multiple
pages.  See further technical notes in lister.p documentation. *)
begin
   writeln(map,'% begin user marks definitions');
   reset(marks);
   waitfornextpiece := false;
   while not eof(marks) do begin
      getmark(marks, map, marksymbol,marktype,
         markbase1,markbits1,markbase2,markbits2,
         markscale,nextmark,waitfornextpiece, marksorder);
         waitfornextpiece := false; (* force advance at each step *)
   end;
   reset(marks);
   waitfornextpiece := true;
end;
(* end module usermarkstopreamble *)

(* begin module initialize *)
procedure initialize;
(* start up the variables *)
var
   reverselist: featuretypeptr; (* a place to hold the feature list
      while we are reversing the items *)
   afeature: featuretypeptr; (* a place to hold a single feature being
      put back onto featurelist *)
   creator: string; (* the author of this program *)
   programname: string; (* the name of this program *)
   headerfile: text; (* temporary file for printing the header information *)
   cmfactor: real; (* convert from cm to points *)
   giveframes: boolean; (* show all amino acid frames without emphasis *)
procedure printtheheader;
(* print header information into the headerfile.
This is part of the initialization *)
begin
   rewrite(headerfile);
   writeln(headerfile,'* lister ',version:4:2,
               '.  a "/" means jump in coordinates.');
   copyaline(book,headerfile);
   linenumber:=linenumber+2;
   writeparameters(headerfile);
end; (* printtheheader *)
procedure printbookheader;
(* only print the book title for the header *)
begin
   rewrite(headerfile);
   copyaline(book,headerfile);
   linenumber:=linenumber+1;
end; (* printbookheader *)
begin (* initialize *)
   readparameters(listerp);

   (* start book variables *)
   brinit(book, theline);
   new(pie);
   orgopen:=false;
   chropen:=false;
   pieopen:=false;
   firstpiece:=true; (* first piece is about to be found *)

   (* read definitions and features *)
writeln(output,'0 BEFORE readdefinitionsandfeatures');
   readdefinitionsandfeatures(features, KeepDuplicates,
                              comments,
                              definitionlist, featurelist, groupnumber,
                              windowsize);

writeln(output,'1 AFTER readdefinitionsandfeatures: definitions');
{
showdefinitions(output, definitionlist);
writeln(output,'2 AFTER readdefinitionsandfeatures: features');
showfeatures(output, featurelist,true);
writeln(output,'3 AFTER readdefinitionsandfeatures: DONE');
}

{
writeln(output,'showto list');
rewrite(list); showfeatures(list, featurelist, true);
halt;
}
if true then begin
   (* show definitions and features for debugging *)
   if (not featuresForward) and (featurelist <> nil) then begin
writeln(output,'FLIPPPER'); {halt;}
      (* Reverse the order of the feature list.
         Only do this if there is more than one feature *)
      if featurelist^.next <> nil then begin
         (* put reverse list to the second feature: *)
         reverselist := featurelist^.next;
         (* make featurelist only the first feature *)
         featurelist^.next := nil;
         (* now take items off reverse list and put them
            on the front of featurelist *)
         while reverselist <> nil do begin
            afeature := reverselist;
            reverselist := reverselist^.next;
            afeature^.next := featurelist;
            featurelist := afeature;
         end;
      end;
   end;
end;
   if debug then begin
      showdefinitions(output, definitionlist);
      showfeatures(output, featurelist,true);
   end;

   pagenumber:=1;
   linenumber:=0;

   rewrite(list);
   if pageaction = 'l' then begin
      writeln(list,'\documentstyle[12pt]{article}');
      writeln(list,'\begin{document}');
      writeln(list,'\begin{verbatim}');
   end;

   if printindex then begin
      rewrite(internalindex);
      writeln(internalindex,'* index to the locations',
                            ' of pieces in this book');
      writeln(internalindex,'*');
   end;

   (* calculate the number of lines in a packet that is printed *)
   (* blank line, numbering, sequence lines and amino acid lines *)
   packet := 2 + seqlines + aalines;

   if mapcontrol then begin

      clearstring(programname);
      programname.letters[1] := 'l';
      programname.letters[2] := 'i';
      programname.letters[3] := 's';
      programname.letters[4] := 't';
      programname.letters[5] := 'e';
      programname.letters[6] := 'r';
      programname.length := 6;

      clearstring(creator);
      creator.letters[ 1] := 'T';
      creator.letters[ 2] := 'o';
      creator.letters[ 3] := 'm';
      creator.letters[ 4] := ' ';
      creator.letters[ 5] := 'S';
      creator.letters[ 6] := 'c';
      creator.letters[ 7] := 'h';
      creator.letters[ 8] := 'n';
      creator.letters[ 9] := 'e';
      creator.letters[10] := 'i';
      creator.letters[11] := 'd';
      creator.letters[12] := 'e';
      creator.letters[13] := 'r';
      creator.length := 13;

      rewrite(map);

      cmperpoint :=
      1 / 72 (* div by points/inch, gives inches/point *)
      * 2.54; (* mul by cm/inch gives cm/point *)

      charwidth :=
         fontsize (* points high *)
         * cmperpoint (* mul by cm/point gives cm *)
         * defcharacterratio; (* mul by width/height gives width *)
      charwidth2m := 2*charwidth;

      cmperbit :=
         fontsize (* points/bit *)
         * cmperpoint; (* mul by cm/point gives cm/bits *)
         (* the height of a character is one bit in this program. *)

      (* compute the bounds of the figure *)
      if pageedges = 'd' then begin (* default page edges *)
         (* Note:  deltaXcm and deltaYcm are applied in the
            PostScript startpage routine in this mode. *)
         llx := defaultllx;
         ury := defaultury;
         urx := defaulturx;
         lly := defaultlly;
      end
      else begin (* page edges shrink wrap to the figure *)
         (* Note that in the postscript, fontsize = lineseparation *)
         if colorlistcontrol = 'C' then begin
            (* default point is upper left corner since writing starts there *)
            llx := defaultllx + deltaXcm/cmperpoint;
            ury := defaultury + deltaYcm/cmperpoint;
            urx := llx + scaleimage*(
                         (2*basesperline (* 2 spaces per base *)
                          + 7 (* 7 is " 5' " and " 3'" *)
                          + extraright)
                         * charwidth/cmperpoint);
            lly := ury - scaleimage*((pagelength) * fontsize);
         end
         else begin (* colorlistcontrol = 'R' => rotate *)
            (* default point is lower left corner since writing starts there *)
            llx := defaultllx - deltaYcm/cmperpoint;
            lly := defaultlly + deltaXcm/cmperpoint;
            urx := llx + scaleimage*((pagelength) * fontsize);
            ury := lly + scaleimage*(
                       (2*basesperline (* 2 spaces per base *)
                        + 7 (* 7 is " 5' " and " 3'" *)
                        + extraright)
                       * charwidth/cmperpoint);
         end
      end;

      (* extra edge control *)
      (* conversion factor from cm to points *)
      cmfactor := 72 / 2.54 ; (* (72 points / inch) / (2.54 cm per inch) *)
      if edgecontrol = 'p' then begin
         (* The code here must match the compensating code at RRR *)
         if colorlistcontrol = 'C' then begin
            llx := llx - edgeleft  * cmfactor; (* C1 *)
            urx := urx + edgeright * cmfactor;
            lly := lly - edgelow   * cmfactor;
            ury := ury + edgehigh  * cmfactor; (* C2 *)
         end
         else begin (* colorlistcontrol = 'R' => rotate *)
            (* in the rotated figure, the left is on the bottom,
               so edgeleft controls lly DOWN, etc.*)
            llx := llx - edgehigh  * cmfactor; (* R1 *)
            urx := urx + edgelow   * cmfactor;
            lly := lly - edgeleft  * cmfactor; (* R2 *)
            ury := ury + edgeright * cmfactor;
         end
      end;


      startpostscript(map, colors, creator, programname,
                             colorlistcontrol, fontsize,
                             deltaXcm, deltaYcm, scaleimage,
                             llx, lly, urx, ury);
      startcosine(map);

      reset(marks);
      waitfornextpiece := true; (* wait for the first piece, which should
                                   happen right away *)
      getmark(marks,map,marksymbol,marktype,
              markbase1,markbits1,markbase2,markbits2,
              markscale,nextmark,waitfornextpiece, marksorder);

      characterinbox(map);
      showingbox := false;

      writeln(map,'/wc {% wcheight wchar wcangle wc; write walker character');
      writeln(map,'/wcangle exch def');
      writeln(map,'/wchar exch def');
      writeln(map,'/wcheight exch lineseparation mul def');
      writeln(map,'/wcdown wcheight 0 lt def');
      writeln(map,'gsave');
      writeln(map,' charwidth2dneg 0 rmoveto');
      writeln(map,' colordictionary wchar get exec');
      write(map,
                 ' charwidth2m ',
                 ' wcheight',
                 ' wchar',
                 ' wcangle',
                 ' wcdown');
      writeln(map,' boxshow');
      writeln(map,'grestore');
      writeln(map,'charwidth 0 rmoveto');
      writeln(map,'} bind def');
      writeln(map);
      writeln(map,'/stopsign {% make a stopsign');
      writeln(map,'gsave');
      writeln(map,' currentpoint translate');
      writeln(map,' charwidth2d dup scale');
      writeln(map,' 0 0 moveto');
      writeln(map,' 1 0 lineto');
      writeln(map,' 2 1 lineto');
      writeln(map,' 2 2 lineto');
      writeln(map,' 1 3 lineto');
      writeln(map,' 0 3 lineto');
      writeln(map,'-1 2 lineto');
      writeln(map,'-1 1 lineto');
      writeln(map,' 0 0 lineto');
      writeln(map,' closepath');
      writeln(map,' gsave');
      writeln(map,'  1 0 0 setrgbcolor'); (* set red *)
      writeln(map,'  fill');
      writeln(map,' grestore');

{
      writeln(map,' gsave');
      writeln(map,'  1 setgray'); (* white *)
      writeln(map,'  0.5 setlinewidth');
      writeln(map,'  clip');
      writeln(map,'  stroke');
      writeln(map,' grestore');
(* *)
      writeln(map,' gsave');
      writeln(map,'  1 0 0 setrgbcolor'); (* red outer edge *)
      writeln(map,'  0.2 setlinewidth');
      writeln(map,'  clip');
      writeln(map,'  stroke');
      writeln(map,' grestore');
(* *)
      writeln(map,' gsave');
      writeln(map,'  1 setgray'); (* white *)
      writeln(map,'  0.5 setlinewidth');
      writeln(map,'  clip');
      writeln(map,'  stroke');
      writeln(map,' grestore');
}
      writeln(map,' gsave');
      writeln(map,'  0 setgray'); (* black *)
      writeln(map,'  0.4 setlinewidth');
      writeln(map,'  clip');
      writeln(map,'  stroke');
      writeln(map,' grestore');
      writeln(map,'grestore');
      writeln(map,'} def');

      writeln(map);

      (* 2004 July 21:
         Notes for letterrectangle control.

         The font rectangle is too high.

         Red book second edition

         Page 271 shows that this is because the character origin is
         above the bottom of the bounding box.  How to obtain this
         information?

         Page 273: "The bounding box for an entire font appears
         in the font dictionary as an array of four numbers
         associated with the key FontBBox."
         Page 282: resets the FontBBox; so a simple call to
         FontBBox should give me the four numbers.

         Red book first edition
         Page 99: shows coordinate system
         Page 100: FontBBox was defined then.

         Red 1st p. 119: currentfont gives current font

         http://www.combinatorics.org/Volume_5/Sourcefiles/v5i1r6/Figure3.epsf
         shows this code:
            currentfont /FontBBox get dup 3 get exch 1 get sub 0.02 mul
         so this:
            currentfont /FontBBox get pstack
         gives on the stack:
         {-43 -278 681 871}
         That's it!

         Red book 1st page 112:
            0 get pstack
         gives the first of the four array elements

         Ok, the move is too big.  FontMatrix?

         Red2 p. 266: "Font Matrix 'Transforms the character coordinate
         system into the user cooridnate system.

            /fbmx currentfont /FontMatrix get def
            fbmx
            pstack
         gives:

         [0.0100000007 0.0 0.0 0.0100000007 0.0 0.0]

      *)

{HHH}
{VVV}

      writeln(map);
      writeln(map,'/letterrectangle {');
      writeln(map,'% petalchar petalX petalY letterrectangle -');
      writeln(map,'% make a rectangle the size of a letter');
      writeln(map,'% shrink the rectangle towards its center');
      writeln(map,'% according to the petalX and petalY.');
      writeln(map,'% If petalX is 0.5, it is half width.');
      writeln(map,'% If petalY is 0.5, it is half height.');
      writeln(map,'% The petalchar is the character at this position.');
      writeln(map,'% If petalchar is ">" or "<" draw an arrow');
      writeln(map,'% instead of a rectangle.');
      writeln(map,'% Color is set outside this function.');
      writeln(map,' /petalY exch def ');
      writeln(map,' /petalX exch def ');
      writeln(map,' /petalchar exch def ');

      writeln(map,'/fbbx currentfont /FontBBox get def');
      writeln(map,'% It turns out that fbbx might not be an');
      writeln(map,'% array, depending on the printer!');
      writeln(map,'% PostScript Language Reference Manual Second Edition');
      writeln(map,'% (Red book):');
      writeln(map,'% /FontBBox: index page 754');
      writeln(map,'%   page 266-267: CLEARLY says it is an array!');
      writeln(map,'%   font metrics and page 273');
      writeln(map,'% code for testing:');
      writeln(map,'% fbbx type (arraytype) eq');
      writeln(map,'% {(true case)}');
      writeln(map,'% {(false case)}');
      writeln(map,'% ifelse');
      writeln(map,'% ');
      writeln(map,'% Test the type of fbbx');
      writeln(map,'fbbx type (arraytype) eq');
      writeln(map,'{ % true case for ghostview');
      writeln(map,'  % (true case) ');

      writeln(map,'  /fbbxllx fbbx 0 get def');
      writeln(map,'  /fbbxlly fbbx 1 get def');
      writeln(map,'  /fbbxurx fbbx 2 get def');
      writeln(map,'  /fbbxury fbbx 3 get def');

      writeln(map,'} ');
      writeln(map,'{ % false case for HP printer');
      writeln(map,'  % (false case) ');
      writeln(map,'  % in this case, the values are on the stack');
      writeln(map,'  % I''m GUESSING the order ...');
      writeln(map,'  % Unfortunately only 3 values are returned!!!');
      writeln(map,'  % Clearly this is a BUG IN THE HP PRINTER!');

      (* # 5 set llx to zero *)
      writeln(map,'  /fbbxury exch def');
      writeln(map,'  0 % put a fake zero on the stack for one of them!');
      writeln(map,'  /fbbxllx exch def');
      writeln(map,'  /fbbxlly exch def');
      writeln(map,'  /fbbxurx exch def');

      (* # 6 set ghostview values *)
      writeln(map,'  /fbbxllx -138 def');
      writeln(map,'  /fbbxlly -278 def');
      writeln(map,'  /fbbxurx  888 def');
      writeln(map,'  /fbbxury 1029 def');

      writeln(map,'}');
      writeln(map,'ifelse');

      writeln(map,'/fmx currentfont /FontMatrix get def');
      writeln(map,'fmx aload pop'); (* need to load the array?? *)
      writeln(map,'/fmx6 exch def');
      writeln(map,'/fmx5 exch def');
      writeln(map,'/fmx4 exch def');
      writeln(map,'/fmx3 exch def');
      writeln(map,'/fmx2 exch def');
      writeln(map,'/fmx1 exch def');
      writeln(map,'gsave');
      writeln(map,' currentpoint moveto');
      writeln(map,' fbbxllx fmx1 mul');
      writeln(map,' fbbxlly fmx4 mul');
      writeln(map,' rmoveto');
      (* we are now at the lower left corner of the character *)
      writeln(map,'% define the characterwidth precisely:');
      writeln(map,'/charwidthF  fbbxurx fbbxllx sub fmx1 mul def');
      writeln(map,'% define the characterheight precisely:');
      writeln(map,'/fontsizeF   fbbxury fbbxlly sub fmx4 mul def');
      (* fontsize * petalY is the final desired thickness.
         Call The amount to shift the rectangle up 'shiftY'.
         Then:
           2*shiftY + fontsize*petalY = fontsize
         solve:
           shiftY = (fontsize/2)*(1-petalY)
         Implement when not an arrow. *)
      writeln(map,' petalchar ( ) eq {');
      writeln(map,'    % draw rectangle');
      writeln(map,'    /petalheight fontsizeF  petalY mul def ');
      writeln(map,'    /petalwidth  charwidthF petalX mul def ');
      writeln(map,'    % shift to account for petalX:');
      writeln(map,'    charwidthF 2 div 1 petalX sub mul');
      writeln(map,'    % shift to account for petalY:');
      writeln(map,'    fontsizeF 2 div 1 petalY sub mul');
      writeln(map,'    rmoveto');
      writeln(map,'    petalwidth 0 rlineto');
      writeln(map,'    0 petalheight  rlineto');
      writeln(map,'    petalwidth neg 0 rlineto');
      writeln(map,' }');
      writeln(map,' {');
      writeln(map,'    % Test these independently');
      writeln(map,'    % to allow flexibility and correct response:');
      writeln(map,'    /fontsize2div fontsizeF 2 div def ');
      writeln(map,'    petalchar (<) eq {');
      writeln(map,'      % draw left arrow tip');
      writeln(map,'      0 fontsize2div rmoveto');
      writeln(map,'      charwidthF fontsize2div neg rlineto');
      writeln(map,'      0 fontsizeF rlineto');
      writeln(map,'    } if');
      writeln(map,'    petalchar (>) eq {');
      writeln(map,'      % draw right arrow tip');
      writeln(map,'      charwidthF fontsize2div rlineto');
      writeln(map,'      charwidthF neg fontsize2div rlineto');
      writeln(map,'    } if');
      writeln(map,' } ifelse');

if superdebug then begin
{use stroke for debugging:}
writeln(map,' closepath stroke');
end
else begin
      {uuu 2004 Aug 16 ORIGINAL AND FINAL CODE IS TO FILL!}
      writeln(map,' closepath fill');
end;

      writeln(map,'grestore');
      writeln(map,'0 setgray % do this to save space');
      writeln(map,'} def % letterrectangle');
      writeln(map);
      usermarkstopreamble;
      writeln(map);
      writeln(map,'%%EndProlog');
   end
   else begin
      writeln(output,'sorry, mapcontrol must be C or R');
      halt;
   end;

   writepagenumber(list, map, mapcontrol,
                   pagenumber,basesperline);

   if printheader then begin
      if hopi[1] <> 'B'
      then printtheheader
      else printbookheader;
      (* write out the header *)
      reset(headerfile);
      while not eof(headerfile) do copyaline(headerfile,list);
      if mapcontrol then writeps(headerfile, map, textline)
   end;

   totallineswritten := 0;
   marksorder:='b'; (* marks before everything *)

   (* initialize getocp variables *)
   orgchange := false; orgopen := false;
   chrchange := false; chropen := false;
   piechange := false; pieopen := false;
   pie := nil;
   theline := 0;

   antiartmode := false;

{original:
   vmmax := 0;
Making vmmax large has big weird effects!
   vmmax := linemax;
   vmmax := linemax-10;
   vmmax := 80;
}
{BRUNCH}

   clearfeaturememory(verticalmemory);
   vmmax := 0;
   clearfeaturememory(horizontalmemory);
   clearfeaturememory(walkermemory);
   wamax := 0;
{uuu}

   dummy := -1;

end;
(* end module initialize *)

(* begin module makelist *)
procedure makelist;
(* make the list by looping through the book *)
var
   f: featuretypeptr; (* current place in the featurelist *)
(* generate the listings *)
procedure donextpage;
(* encapsulate the nextpage call to simplify the code below *)
begin nextpage(list,map,mapcontrol,linenumber,pagenumber,basesperline) end;
begin
      while not eof(book) do begin
         getocp(book,theline,theorg,orgchange,orgopen,
                     thechr,chrchange,chropen,
                     pie,   piechange,pieopen);
         if not eof(book) then begin
            (* since we have a new piece, don't wait to do any marks in it *)
            if waitfornextpiece
            then begin
              waitfornextpiece := false;
              getmark(marks,map,marksymbol,marktype,
                 markbase1,markbits1,markbase2,markbits2,
                 markscale,nextmark,waitfornextpiece, marksorder)
            end
            else waitfornextpiece := false;

            if not firstpiece then begin

               (* Reset the feature list so that there are no carryover
                  effects of the desires of a feature from one piece to the
                  next.  1999 May 8:  The barger bug is probably solved by
                  this chunk of code:  It was caused by the desires of the
                  features on previous pieces.  By setting the desires to the
                  initial state the problem cleared. *)

               f := featurelist; (* start over again with a new line *)
               while f <> nil do with f^ do with f^.definition^ do begin
               {
               writeln(output,'looping');
               writeln(output,'unsatisfied = ',unsatisfied);
               writeln(output,'desiredline = ',desiredline:1);
               }
                  unsatisfied := true;
                  desiredline := 0;
                  f := f^.next
               end;

               (* at each piece, clear the vertical memory *)
               clearfeaturememory(verticalmemory);
{vvv}

               (* the horizontal memory might have to be cleared more
                  often but surely at least at every piece:}
               clearfeaturememory(horizontalmemory);

               (* the walker memory only be cleared at the piece *)
               clearfeaturememory(walkermemory);
{uuu}

                    if decapitalize(pagetrigger) = 'p'
               then donextpage
               else if orgchange and (decapitalize(pagetrigger) = 'o')
               then donextpage
               else if chrchange and (decapitalize(pagetrigger) = 'c')
               then donextpage
               else if decapitalize(pagetrigger) = 'l' then begin
                  if ptrig <> nil then begin
{
writeln(output,'number = ',number:1);
writeln(output,'ptrig^.trigger = ',ptrig^.trigger:1);
}
                     if ptrig^.trigger = number then begin
{
writeln(output,'triggered');
}
                        donextpage;
                        if ptrig <> nil then ptrig := ptrig^.next;
                     end
                  end
               end
               else if decapitalize(pagetrigger) = 'd' then begin
                  (* if we are past the first piece and the piece
                     number is odd, then page.  This results in two
                     sequences per page (double) *)
                  if (number > 1) and ((number mod 2) = 1)
                  then donextpage
               end
            end;

            (* show organism and chromosome *)
            if orgchange or chrchange then begin
                if printindex then begin
                   writeln(internalindex,'*'); (* keep space between things *)
                   write(internalindex,'* ');
                end;
            end;
            if printorgchr then begin
               write(list,'* ');
               iworgchr(list,theorg,orgchange,orgopen,
                             thechr,chrchange,orgopen);

               if mapcontrol then begin
                  write(map,'(* ');
                  iworgchr(map,theorg,orgchange,orgopen,
                               thechr,chrchange,orgopen);
                  writeln(map,') s n');
               end;
            end;

            if printindex
            then iworgchr(internalindex,theorg,orgchange,orgopen,
                                        thechr,chrchange,orgopen);

            (* take care of the writeln of the above iws.
               by simulating proc. nextline *)
            if orgchange or chrchange then begin
               linenumber:=succ(linenumber);
               if linenumber > pagelength
               then nextpage(list,map,mapcontrol,
                             linenumber,pagenumber,basesperline)
            end;

            if orgchange then clearheader(theorg.hea);
            if chrchange then clearheader(thechr.hea);

            if printpiece then begin
               (* show piece *)
               write(list,'*');
               showpiece(list,pie,nkfc);
               writeln(list);
               if mapcontrol then begin
                  write(map,'(');
                  showpiece(map,pie,nkfc);
                  writeln(map,') s');
               end;
               nextline(list,map,mapcontrol,true,
                        linenumber,pagenumber,basesperline, dummy, textline)
            end;

            if printindex then begin
               (* index the piece *)
               write(internalindex,'* page ',pagenumber:4);
               write(internalindex, ', piece');
               if numbered then write(internalindex,' ',number:4);
               with pie^.key.hea
               do write(internalindex, ', ',keynam.letters:keynam.length,
                                       ', ',fulnam^.letters:fulnam^.length);
               writeln(internalindex)
            end;

            listdatalines(list,map,pie,shiftsequence, textline, giveframes);
            clearpiece(pie);

            (* the next organism will not be the first: *)
            firstpiece:=false
         end
      end;
      dispose(pie);

      if pageaction = 'l' then begin
         writeln(list,'\end{verbatim}');
         writeln(list,'\end{document}');
      end;
end; (* makelist *)
(* end module makelist *)

(* begin module makeindex *)
procedure makeindex;
(* copy the index onto the bottom of the list *)
begin
   if printindex then begin
      nextpage(list, map, mapcontrol,
                    linenumber,pagenumber,basesperline);
      reset(internalindex);
      while not eof(internalindex)
      do copyaline(internalindex, list);
      if mapcontrol then begin
         writeps(internalindex, map, textline);
      end;
   end;
end;
(* end module makeindex *)

(* begin module finalize *)
procedure finalize;
(* finish off whatever *)
begin
   if mapcontrol then begin
      if linenumber > 2 then writeln(map,'endpage');
{
2004 Feb 6:
CANNOT DO THIS FOR THE ENTIRE FIGURE!!!
That now prevents one from moving backwards in Ghostview.
      writeln(map,'grestore % allows embedding entire figure');
}
      writeln(map,'%%Trailer');
      writeln(map,'%%Pages: ',pagenumber:1);
   end;
   write(output, pagenumber:1, ' page');
   plural(output, pagenumber);
   writeln(output,' written');

   (* Attempt to get more marks.  This will skip any comments
      so that the message below is avoided.  If there ARE marks,
      then the message will be presented to the user. *)
(* writeln(output,'waitfornextpiece = ', waitfornextpiece); *)
   waitfornextpiece := false; (* force proceeding through the marks file *)
   getmark(marks,map,marksymbol,marktype,
                 markbase1,markbits1,markbase2,markbits2,
                 markscale,nextmark,waitfornextpiece, marksorder);
   if not eof(marks) then begin
writeln(output,'************************************************************');
writeln(output,'* WARNING: the marks file has not been read to completion! *');
writeln(output,'*          You probably have put your marks out of order.  *');
{aaa}
writeln(output,'*          The mark that could not be placed is:           *');
writeln(output,marksymbol,' ',markbase1:5:3, ' ',markbits1:5:3,
                          ' ',markbase2:5:3, ' ',markbits2:5:3,
                          ' ',markscale:5:3,' ',nextmark:5);
writeln(output,'*** You should see any mark(s) before that one on the map. *');
writeln(output,'*** KEEP IN MIND THAT MARKS MUST BE PLACED IN THE ORDER  ***');
writeln(output,'*** OF THE BOOK SEQUENCE COORDINATES!                    ***');
writeln(output,'*** BELOW IS THE REMAINDER OF THE MARKS FILE,            ***');
writeln(output,'*** NONE OF THESE MARKS WERE PLACED:                     ***');
copyfile(marks, output);
writeln(output,'************************************************************');
   end;
end;
(* end module finalize *)

(* 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.88; (@ of prgmod.p 2022 Dec 20 *)

begin (* lister *)
   writeln(output,'lister ',version:4:2);
   patentmessage(output);
   limitdate ('9','9','9','9','    /99/99 99:99:99');
   initialize;
   makelist;
   makeindex;
   finalize;
1: end. (* lister *)
