home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / unixtex-6.1b-src.tgz / tar.out / contrib / unixtex / web2c / mf / mf.web (.txt) < prev    next >
Encoding:
Texinfo Document  |  1996-09-28  |  896.5 KB  |  19,941 lines

  1. % This program is copyright (C) 1984 by D. E. Knuth; all rights are reserved.
  2. % Copying of this file is authorized only if (1) you are D. E. Knuth, or if
  3. % (2) you make absolutely no changes to your copy. (The WEB system provides
  4. % for alterations via an auxiliary file; the master file should stay intact.)
  5. % In other words, METAFONT is under essentially the same ground rules as TeX.
  6. % TeX is a trademark of the American Mathematical Society.
  7. % METAFONT is a trademark of Addison-Wesley Publishing Company.
  8. % Version 0 was completed on July 28, 1984.
  9. % Version 1 was completed on January 4, 1986; it corresponds to "Volume D".
  10. % Version 1.1 trivially corrected the punctuation in one message (June 1986).
  11. % Version 1.2 corrected an arithmetic overflow problem (July 1986).
  12. % Version 1.3 improved rounding when elliptical pens are made (November 1986).
  13. % Version 1.4 corrected scan_declared_variable timing (May 1988).
  14. % Version 1.5 fixed negative halving in allocator when mem_min<0 (June 1988).
  15. % Version 1.6 kept open_log_file from calling fatal_error (November 1988).
  16. % Version 1.7 solved that problem a better way (December 1988).
  17. % Version 1.8 introduced major changes for 8-bit extensions (September 1989).
  18. % Version 1.9 improved skimping and was edited for style (December 1989).
  19. % Version 2.0 fixed bug in addto; released with TeX version 3.0 (March 1990).
  20. % Version 2.7 made consistent with TeX version 3.1 (September 1990).
  21. % Version 2.71 fixed bug in draw, allowed unprintable filenames (March 1992).
  22. % A few "harmless" optimizations have been made without changing versions.
  23. % A reward of $163.84 will be paid to the first finder of any remaining bug,
  24. % except bugs introduced after August 1989.
  25. % Although considerable effort has been expended to make the METAFONT program
  26. % correct and reliable, no warranty is implied; the author disclaims any
  27. % obligation or liability for damages, including but not limited to
  28. % special, indirect, or consequential damages arising out of or in
  29. % connection with the use or performance of this software. This work has
  30. % been a ``labor of love'' and the author hopes that users enjoy it.
  31. % Here is TeX material that gets inserted after \input webmac
  32. \def\hang{\hangindent 3em\noindent\ignorespaces}
  33. \def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces}
  34. \font\ninerm=cmr9
  35. \let\mc=\ninerm % medium caps for names like SAIL
  36. \def\PASCAL{Pascal}
  37. \def\ph{\hbox{Pascal-H}}
  38. \def\psqrt#1{\sqrt{\mathstrut#1}}
  39. \def\k{_{k+1}}
  40. \def\pct!{{\char`\%}} % percent sign in ordinary text
  41. \font\tenlogo=logo10 % font used for the METAFONT logo
  42. \font\logos=logosl10
  43. \font\eightlogo=logo8
  44. \def\MF{{\tenlogo META}\-{\tenlogo FONT}}
  45. \def\<#1>{$\langle#1\rangle$}
  46. \def\section{\mathhexbox278}
  47. \let\swap=\leftrightarrow
  48. \def\round{\mathop{\rm round}\nolimits}
  49. \def\(#1){} % this is used to make section names sort themselves better
  50. \def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@>
  51. \outer\def\N#1. \[#2]#3.{\MN#1.\vfil\eject % begin starred section
  52.   \def\rhead{PART #2:\uppercase{#3}} % define running headline
  53.   \message{*\modno} % progress report
  54.   \edef\next{\write\cont{\Z{\?#2]#3}{\modno}{\the\pageno}}}\next
  55.   \ifon\startsection{\bf\ignorespaces#3.\quad}\ignorespaces}
  56. \let\?=\relax % we want to be able to \write a \?
  57. \def\title{{\eightlogo METAFONT}}
  58. \def\topofcontents{\hsize 5.5in
  59.   \vglue -30pt plus 1fil minus 1.5in
  60.   \def\?##1]{\hbox to 1in{\hfil##1.\ }}
  61. \def\botofcontents{\vskip 0pt plus 1fil minus 1.5in}
  62. \pageno=3
  63. \def\glob{13} % this should be the section number of "<Global...>"
  64. \def\gglob{20, 26} % this should be the next two sections of "<Global...>"
  65. @* \[1] Introduction.
  66. This is \MF, a font compiler intended to produce typefaces of high quality.
  67. The \PASCAL\ program that follows is the definition of \MF84, a standard
  68. @:PASCAL}{\PASCAL@>
  69. @!@:METAFONT84}{\MF84@>
  70. version of \MF\ that is designed to be highly portable so that identical output
  71. will be obtainable on a great variety of computers. The conventions
  72. of \MF84 are the same as those of \TeX82.
  73. The main purpose of the following program is to explain the algorithms of \MF\
  74. as clearly as possible. As a result, the program will not necessarily be very
  75. efficient when a particular \PASCAL\ compiler has translated it into a
  76. particular machine language. However, the program has been written so that it
  77. can be tuned to run efficiently in a wide variety of operating environments
  78. by making comparatively few changes. Such flexibility is possible because
  79. the documentation that follows is written in the \.{WEB} language, which is
  80. at a higher level than \PASCAL; the preprocessing step that converts \.{WEB}
  81. to \PASCAL\ is able to introduce most of the necessary refinements.
  82. Semi-automatic translation to other languages is also feasible, because the
  83. program below does not make extensive use of features that are peculiar to
  84. \PASCAL.
  85. A large piece of software like \MF\ has inherent complexity that cannot
  86. be reduced below a certain level of difficulty, although each individual
  87. part is fairly simple by itself. The \.{WEB} language is intended to make
  88. the algorithms as readable as possible, by reflecting the way the
  89. individual program pieces fit together and by providing the
  90. cross-references that connect different parts. Detailed comments about
  91. what is going on, and about why things were done in certain ways, have
  92. been liberally sprinkled throughout the program.  These comments explain
  93. features of the implementation, but they rarely attempt to explain the
  94. \MF\ language itself, since the reader is supposed to be familiar with
  95. {\sl The {\logos METAFONT\/}book}.
  96. @.WEB@>
  97. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  98. @ The present implementation has a long ancestry, beginning in the spring
  99. of~1977, when its author wrote a prototype set of subroutines and macros
  100. @^Knuth, Donald Ervin@>
  101. that were used to develop the first Computer Modern fonts.
  102. This original proto-\MF\ required the user to recompile a {\mc SAIL} program
  103. whenever any character was changed, because it was not a ``language'' for
  104. font design; the language was {\mc SAIL}. After several hundred characters
  105. had been designed in that way, the author developed an interpretable language
  106. called \MF, in which it was possible to express the Computer Modern programs
  107. less cryptically. A complete \MF\ processor was designed and coded by the
  108. author in 1979. This program, written in {\mc SAIL}, was adapted for use
  109. with a variety of typesetting equipment and display terminals by Leo Guibas,
  110. Lyle Ramshaw, and David Fuchs.
  111. @^Guibas, Leonidas Ioannis@>
  112. @^Ramshaw, Lyle Harold@>
  113. @^Fuchs, David Raymond@>
  114. Major improvements to the design of Computer Modern fonts were made in the
  115. spring of 1982, after which it became clear that a new language would
  116. better express the needs of letterform designers. Therefore an entirely
  117. new \MF\ language and system were developed in 1984; the present system
  118. retains the name and some of the spirit of \MF79, but all of the details
  119. have changed.
  120. No doubt there still is plenty of room for improvement, but the author
  121. is firmly committed to keeping \MF84 ``frozen'' from now on; stability
  122. and reliability are to be its main virtues.
  123. On the other hand, the \.{WEB} description can be extended without changing
  124. the core of \MF84 itself, and the program has been designed so that such
  125. extensions are not extremely difficult to make.
  126. The |banner| string defined here should be changed whenever \MF\
  127. undergoes any modifications, so that it will be clear which version of
  128. \MF\ might be the guilty party when a problem arises.
  129. @^extensions to \MF@>
  130. @^system dependencies@>
  131. If this program is changed, the resulting system should not be called
  132. `\MF\kern.5pt'; the official name `\MF\kern.5pt' by itself is reserved
  133. for software systems that are fully compatible with each other.
  134. A special test suite called the ``\.{TRAP} test'' is available for
  135. helping to determine whether an implementation deserves to be
  136. known as `\MF\kern.5pt' [cf.~Stanford Computer Science report CS1095,
  137. January 1986].
  138. @d banner=='This is METAFONT, Version 2.71' {printed when \MF\ starts}
  139. @ Different \PASCAL s have slightly different conventions, and the present
  140. @!@:PASCAL H}{\ph@>
  141. program expresses \MF\ in terms of the \PASCAL\ that was
  142. available to the author in 1984. Constructions that apply to
  143. this particular compiler, which we shall call \ph, should help the
  144. reader see how to make an appropriate interface for other systems
  145. if necessary. (\ph\ is Charles Hedrick's modification of a compiler
  146. @^Hedrick, Charles Locke@>
  147. for the DECsystem-10 that was originally developed at the University of
  148. Hamburg; cf.\ {\sl SOFTWARE---Practice \AM\ Experience \bf6} (1976),
  149. 29--42. The \MF\ program below is intended to be adaptable, without
  150. extensive changes, to most other versions of \PASCAL, so it does not fully
  151. use the admirable features of \ph. Indeed, a conscious effort has been
  152. made here to avoid using several idiosyncratic features of standard
  153. \PASCAL\ itself, so that most of the code can be translated mechanically
  154. into other high-level languages. For example, the `\&{with}' and `\\{new}'
  155. features are not used, nor are pointer types, set types, or enumerated
  156. scalar types; there are no `\&{var}' parameters, except in the case of files;
  157. there are no tag fields on variant records; there are no |real| variables;
  158. no procedures are declared local to other procedures.)
  159. The portions of this program that involve system-dependent code, where
  160. changes might be necessary because of differences between \PASCAL\ compilers
  161. and/or differences between
  162. operating systems, can be identified by looking at the sections whose
  163. numbers are listed under `system dependencies' in the index. Furthermore,
  164. the index entries for `dirty \PASCAL' list all places where the restrictions
  165. of \PASCAL\ have not been followed perfectly, for one reason or another.
  166. @!@^system dependencies@>
  167. @!@^dirty \PASCAL@>
  168. @ The program begins with a normal \PASCAL\ program heading, whose
  169. components will be filled in later, using the conventions of \.{WEB}.
  170. @.WEB@>
  171. For example, the portion of the program called `\X\glob:Global
  172. variables\X' below will be replaced by a sequence of variable declarations
  173. that starts in $\section\glob$ of this documentation. In this way, we are able
  174. to define each individual global variable when we are prepared to
  175. understand what it means; we do not have to define all of the globals at
  176. once.  Cross references in $\section\glob$, where it says ``See also
  177. sections \gglob, \dots,'' also make it possible to look at the set of
  178. all global variables, if desired.  Similar remarks apply to the other
  179. portions of the program heading.
  180. Actually the heading shown here is not quite normal: The |program| line
  181. does not mention any |output| file, because \ph\ would ask the \MF\ user
  182. to specify a file name if |output| were specified here.
  183. @^system dependencies@>
  184. @d mtype==t@&y@&p@&e {this is a \.{WEB} coding trick:}
  185. @f mtype==type {`\&{mtype}' will be equivalent to `\&{type}'}
  186. @f type==true {but `|type|' will not be treated as a reserved word}
  187. @p @t\4@>@<Compiler directives@>@/
  188. program MF; {all file names are defined dynamically}
  189. label @<Labels in the outer block@>@/
  190. const @<Constants in the outer block@>@/
  191. mtype @<Types in the outer block@>@/
  192. var @<Global variables@>@/
  193. procedure initialize; {this procedure gets things started properly}
  194.   var @<Local variables for initialization@>@/
  195.   begin @<Set initial values of key variables@>@/
  196.   end;@#
  197. @t\4@>@<Basic printing procedures@>@/
  198. @t\4@>@<Error handling procedures@>@/
  199. @ The overall \MF\ program begins with the heading just shown, after which
  200. comes a bunch of procedure declarations and function declarations.
  201. Finally we will get to the main program, which begins with the
  202. comment `|start_here|'. If you want to skip down to the
  203. main program now, you can look up `|start_here|' in the index.
  204. But the author suggests that the best way to understand this program
  205. is to follow pretty much the order of \MF's components as they appear in the
  206. \.{WEB} description you are now reading, since the present ordering is
  207. intended to combine the advantages of the ``bottom up'' and ``top down''
  208. approaches to the problem of understanding a somewhat complicated system.
  209. @ Three labels must be declared in the main program, so we give them
  210. symbolic names.
  211. @d start_of_MF=1 {go here when \MF's variables are initialized}
  212. @d end_of_MF=9998 {go here to close files and terminate gracefully}
  213. @d final_end=9999 {this label marks the ending of the program}
  214. @<Labels in the out...@>=
  215. start_of_MF@t\hskip-2pt@>, end_of_MF@t\hskip-2pt@>,@,final_end;
  216.   {key control points}
  217. @ Some of the code below is intended to be used only when diagnosing the
  218. strange behavior that sometimes occurs when \MF\ is being installed or
  219. when system wizards are fooling around with \MF\ without quite knowing
  220. what they are doing. Such code will not normally be compiled; it is
  221. delimited by the codewords `$|debug|\ldots|gubed|$', with apologies
  222. to people who wish to preserve the purity of English.
  223. Similarly, there is some conditional code delimited by
  224. `$|stat|\ldots|tats|$' that is intended for use when statistics are to be
  225. kept about \MF's memory usage.  The |stat| $\ldots$ |tats| code also
  226. implements special diagnostic information that is printed when
  227. $\\{tracingedges}>1$.
  228. @^debugging@>
  229. @d debug==@{ {change this to `$\\{debug}\equiv\null$' when debugging}
  230. @d gubed==@t@>@} {change this to `$\\{gubed}\equiv\null$' when debugging}
  231. @f debug==begin
  232. @f gubed==end
  233. @d stat==@{ {change this to `$\\{stat}\equiv\null$' when gathering
  234.   usage statistics}
  235. @d tats==@t@>@} {change this to `$\\{tats}\equiv\null$' when gathering
  236.   usage statistics}
  237. @f stat==begin
  238. @f tats==end
  239. @ This program has two important variations: (1) There is a long and slow
  240. version called \.{INIMF}, which does the extra calculations needed to
  241. @.INIMF@>
  242. initialize \MF's internal tables; and (2)~there is a shorter and faster
  243. production version, which cuts the initialization to a bare minimum.
  244. Parts of the program that are needed in (1) but not in (2) are delimited by
  245. the codewords `$|init|\ldots|tini|$'.
  246. @d init== {change this to `$\\{init}\equiv\.{@@\{}$' in the production version}
  247. @d tini== {change this to `$\\{tini}\equiv\.{@@\}}$' in the production version}
  248. @f init==begin
  249. @f tini==end
  250. @ If the first character of a \PASCAL\ comment is a dollar sign,
  251. \ph\ treats the comment as a list of ``compiler directives'' that will
  252. affect the translation of this program into machine language.  The
  253. directives shown below specify full checking and inclusion of the \PASCAL\
  254. debugger when \MF\ is being debugged, but they cause range checking and other
  255. redundant code to be eliminated when the production system is being generated.
  256. Arithmetic overflow will be detected in all cases.
  257. @^system dependencies@>
  258. @^Overflow in arithmetic@>
  259. @<Compiler directives@>=
  260. @{@&$C-,A+,D-@} {no range check, catch arithmetic overflow, no debug overhead}
  261. @!debug @{@&$C+,D+@}@+ gubed {but turn everything on when debugging}
  262. @ This \MF\ implementation conforms to the rules of the {\sl Pascal User
  263. @:PASCAL}{\PASCAL@>
  264. @^system dependencies@>
  265. Manual} published by Jensen and Wirth in 1975, except where system-dependent
  266. @^Wirth, Niklaus@>
  267. @^Jensen, Kathleen@>
  268. code is necessary to make a useful system program, and except in another
  269. respect where such conformity would unnecessarily obscure the meaning
  270. and clutter up the code: We assume that |case| statements may include a
  271. default case that applies if no matching label is found. Thus, we shall use
  272. constructions like
  273. $$\vbox{\halign{\ignorespaces#\hfil\cr
  274. |case x of|\cr
  275. 1: $\langle\,$code for $x=1\,\rangle$;\cr
  276. 3: $\langle\,$code for $x=3\,\rangle$;\cr
  277. |othercases| $\langle\,$code for |x<>1| and |x<>3|$\,\rangle$\cr
  278. |endcases|\cr}}$$
  279. since most \PASCAL\ compilers have plugged this hole in the language by
  280. incorporating some sort of default mechanism. For example, the \ph\
  281. compiler allows `|others|:' as a default label, and other \PASCAL s allow
  282. syntaxes like `\&{else}' or `\&{otherwise}' or `\\{otherwise}:', etc. The
  283. definitions of |othercases| and |endcases| should be changed to agree with
  284. local conventions.  Note that no semicolon appears before |endcases| in
  285. this program, so the definition of |endcases| should include a semicolon
  286. if the compiler wants one. (Of course, if no default mechanism is
  287. available, the |case| statements of \MF\ will have to be laboriously
  288. extended by listing all remaining cases. People who are stuck with such
  289. \PASCAL s have, in fact, done this, successfully but not happily!)
  290. @d othercases == others: {default for cases not listed explicitly}
  291. @d endcases == @+end {follows the default case in an extended |case| statement}
  292. @f othercases == else
  293. @f endcases == end
  294. @ The following parameters can be changed at compile time to extend or
  295. reduce \MF's capacity. They may have different values in \.{INIMF} and
  296. in production versions of \MF.
  297. @.INIMF@>
  298. @^system dependencies@>
  299. @<Constants...@>=
  300. @!mem_max=30000; {greatest index in \MF's internal |mem| array;
  301.   must be strictly less than |max_halfword|;
  302.   must be equal to |mem_top| in \.{INIMF}, otherwise |>=mem_top|}
  303. @!max_internal=100; {maximum number of internal quantities}
  304. @!buf_size=500; {maximum number of characters simultaneously present in
  305.   current lines of open files; must not exceed |max_halfword|}
  306. @!error_line=72; {width of context lines on terminal error messages}
  307. @!half_error_line=42; {width of first lines of contexts in terminal
  308.   error messages; should be between 30 and |error_line-15|}
  309. @!max_print_line=79; {width of longest text lines output; should be at least 60}
  310. @!screen_width=768; {number of pixels in each row of screen display}
  311. @!screen_depth=1024; {number of pixels in each column of screen display}
  312. @!stack_size=30; {maximum number of simultaneous input sources}
  313. @!max_strings=2000; {maximum number of strings; must not exceed |max_halfword|}
  314. @!string_vacancies=8000; {the minimum number of characters that should be
  315.   available for the user's identifier names and strings,
  316.   after \MF's own error messages are stored}
  317. @!pool_size=32000; {maximum number of characters in strings, including all
  318.   error messages and help texts, and the names of all identifiers;
  319.   must exceed |string_vacancies| by the total
  320.   length of \MF's own strings, which is currently about 22000}
  321. @!move_size=5000; {space for storing moves in a single octant}
  322. @!max_wiggle=300; {number of autorounded points per cycle}
  323. @!gf_buf_size=800; {size of the output buffer, must be a multiple of 8}
  324. @!file_name_size=40; {file names shouldn't be longer than this}
  325. @!pool_name='MFbases:MF.POOL                         ';
  326.   {string of length |file_name_size|; tells where the string pool appears}
  327. @.MFbases@>
  328. @!path_size=300; {maximum number of knots between breakpoints of a path}
  329. @!bistack_size=785; {size of stack for bisection algorithms;
  330.   should probably be left at this value}
  331. @!header_size=100; {maximum number of \.{TFM} header words, times~4}
  332. @!lig_table_size=5000; {maximum number of ligature/kern steps, must be
  333.   at least 255 and at most 32510}
  334. @!max_kerns=500; {maximum number of distinct kern amounts}
  335. @!max_font_dimen=50; {maximum number of \&{fontdimen} parameters}
  336. @ Like the preceding parameters, the following quantities can be changed
  337. at compile time to extend or reduce \MF's capacity. But if they are changed,
  338. it is necessary to rerun the initialization program \.{INIMF}
  339. @.INIMF@>
  340. to generate new tables for the production \MF\ program.
  341. One can't simply make helter-skelter changes to the following constants,
  342. since certain rather complex initialization
  343. numbers are computed from them. They are defined here using
  344. \.{WEB} macros, instead of being put into \PASCAL's |const| list, in order to
  345. emphasize this distinction.
  346. @d mem_min=0 {smallest index in the |mem| array, must not be less
  347.   than |min_halfword|}
  348. @d mem_top==30000 {largest index in the |mem| array dumped by \.{INIMF};
  349.   must be substantially larger than |mem_min|
  350.   and not greater than |mem_max|}
  351. @d hash_size=2100 {maximum number of symbolic tokens,
  352.   must be less than |max_halfword-3*param_size|}
  353. @d hash_prime=1777 {a prime number equal to about 85\pct! of |hash_size|}
  354. @d max_in_open=6 {maximum number of input files and error insertions that
  355.   can be going on simultaneously}
  356. @d param_size=150 {maximum number of simultaneous macro parameters}
  357. @^system dependencies@>
  358. @ In case somebody has inadvertently made bad settings of the ``constants,''
  359. \MF\ checks them using a global variable called |bad|.
  360. This is the first of many sections of \MF\ where global variables are
  361. defined.
  362. @<Glob...@>=
  363. @!bad:integer; {is some ``constant'' wrong?}
  364. @ Later on we will say `\ignorespaces|if mem_max>=max_halfword then bad:=10|',
  365. or something similar. (We can't do that until |max_halfword| has been defined.)
  366. @<Check the ``constant'' values for consistency@>=
  367. bad:=0;
  368. if (half_error_line<30)or(half_error_line>error_line-15) then bad:=1;
  369. if max_print_line<60 then bad:=2;
  370. if gf_buf_size mod 8<>0 then bad:=3;
  371. if mem_min+1100>mem_top then bad:=4;
  372. if hash_prime>hash_size then bad:=5;
  373. if header_size mod 4 <> 0 then bad:=6;
  374. if(lig_table_size<255)or(lig_table_size>32510)then bad:=7;
  375. @ Labels are given symbolic names by the following definitions, so that
  376. occasional |goto| statements will be meaningful. We insert the label
  377. `|exit|:' just before the `\ignorespaces|end|\unskip' of a procedure in
  378. which we have used the `|return|' statement defined below; the label
  379. `|restart|' is occasionally used at the very beginning of a procedure; and
  380. the label `|reswitch|' is occasionally used just prior to a |case|
  381. statement in which some cases change the conditions and we wish to branch
  382. to the newly applicable case.  Loops that are set up with the |loop|
  383. construction defined below are commonly exited by going to `|done|' or to
  384. `|found|' or to `|not_found|', and they are sometimes repeated by going to
  385. `|continue|'.  If two or more parts of a subroutine start differently but
  386. end up the same, the shared code may be gathered together at
  387. `|common_ending|'.
  388. Incidentally, this program never declares a label that isn't actually used,
  389. because some fussy \PASCAL\ compilers will complain about redundant labels.
  390. @d exit=10 {go here to leave a procedure}
  391. @d restart=20 {go here to start a procedure again}
  392. @d reswitch=21 {go here to start a case statement again}
  393. @d continue=22 {go here to resume a loop}
  394. @d done=30 {go here to exit a loop}
  395. @d done1=31 {like |done|, when there is more than one loop}
  396. @d done2=32 {for exiting the second loop in a long block}
  397. @d done3=33 {for exiting the third loop in a very long block}
  398. @d done4=34 {for exiting the fourth loop in an extremely long block}
  399. @d done5=35 {for exiting the fifth loop in an immense block}
  400. @d done6=36 {for exiting the sixth loop in a block}
  401. @d found=40 {go here when you've found it}
  402. @d found1=41 {like |found|, when there's more than one per routine}
  403. @d found2=42 {like |found|, when there's more than two per routine}
  404. @d not_found=45 {go here when you've found nothing}
  405. @d common_ending=50 {go here when you want to merge with another branch}
  406. @ Here are some macros for common programming idioms.
  407. @d incr(#) == #:=#+1 {increase a variable by unity}
  408. @d decr(#) == #:=#-1 {decrease a variable by unity}
  409. @d negate(#) == #:=-# {change the sign of a variable}
  410. @d double(#) == #:=#+# {multiply a variable by two}
  411. @d loop == @+ while true do@+ {repeat over and over until a |goto| happens}
  412. @f loop == xclause
  413.   {\.{WEB}'s |xclause| acts like `\ignorespaces|while true do|\unskip'}
  414. @d do_nothing == {empty statement}
  415. @d return == goto exit {terminate a procedure call}
  416. @f return == nil {\.{WEB} will henceforth say |return| instead of \\{return}}
  417. @* \[2] The character set.
  418. In order to make \MF\ readily portable to a wide variety of
  419. computers, all of its input text is converted to an internal eight-bit
  420. code that includes standard ASCII, the ``American Standard Code for
  421. Information Interchange.''  This conversion is done immediately when each
  422. character is read in. Conversely, characters are converted from ASCII to
  423. the user's external representation just before they are output to a
  424. text file.
  425. @^ASCII code@>
  426. Such an internal code is relevant to users of \MF\ only with respect to
  427. the \&{char} and \&{ASCII} operations, and the comparison of strings.
  428. @ Characters of text that have been converted to \MF's internal form
  429. are said to be of type |ASCII_code|, which is a subrange of the integers.
  430. @<Types...@>=
  431. @!ASCII_code=0..255; {eight-bit numbers}
  432. @ The original \PASCAL\ compiler was designed in the late 60s, when six-bit
  433. character sets were common, so it did not make provision for lowercase
  434. letters. Nowadays, of course, we need to deal with both capital and small
  435. letters in a convenient way, especially in a program for font design;
  436. so the present specification of \MF\ has been written under the assumption
  437. that the \PASCAL\ compiler and run-time system permit the use of text files
  438. with more than 64 distinguishable characters. More precisely, we assume that
  439. the character set contains at least the letters and symbols associated
  440. with ASCII codes @'40 through @'176; all of these characters are now
  441. available on most computer terminals.
  442. Since we are dealing with more characters than were present in the first
  443. \PASCAL\ compilers, we have to decide what to call the associated data
  444. type. Some \PASCAL s use the original name |char| for the
  445. characters in text files, even though there now are more than 64 such
  446. characters, while other \PASCAL s consider |char| to be a 64-element
  447. subrange of a larger data type that has some other name.
  448. In order to accommodate this difference, we shall use the name |text_char|
  449. to stand for the data type of the characters that are converted to and
  450. from |ASCII_code| when they are input and output. We shall also assume
  451. that |text_char| consists of the elements |chr(first_text_char)| through
  452. |chr(last_text_char)|, inclusive. The following definitions should be
  453. adjusted if necessary.
  454. @^system dependencies@>
  455. @d text_char == char {the data type of characters in text files}
  456. @d first_text_char=0 {ordinal number of the smallest element of |text_char|}
  457. @d last_text_char=255 {ordinal number of the largest element of |text_char|}
  458. @<Local variables for init...@>=
  459. @!i:integer;
  460. @ The \MF\ processor converts between ASCII code and
  461. the user's external character set by means of arrays |xord| and |xchr|
  462. that are analogous to \PASCAL's |ord| and |chr| functions.
  463. @<Glob...@>=
  464. @!xord: array [text_char] of ASCII_code;
  465.   {specifies conversion of input characters}
  466. @!xchr: array [ASCII_code] of text_char;
  467.   {specifies conversion of output characters}
  468. @ Since we are assuming that our \PASCAL\ system is able to read and
  469. write the visible characters of standard ASCII (although not
  470. necessarily using the ASCII codes to represent them), the following
  471. assignment statements initialize the standard part of the |xchr| array
  472. properly, without needing any system-dependent changes. On the other
  473. hand, it is possible to implement \MF\ with less complete character
  474. sets, and in such cases it will be necessary to change something here.
  475. @^system dependencies@>
  476. @<Set init...@>=
  477. xchr[@'40]:=' ';
  478. xchr[@'41]:='!';
  479. xchr[@'42]:='"';
  480. xchr[@'43]:='#';
  481. xchr[@'44]:='$';
  482. xchr[@'45]:='%';
  483. xchr[@'46]:='&';
  484. xchr[@'47]:='''';@/
  485. xchr[@'50]:='(';
  486. xchr[@'51]:=')';
  487. xchr[@'52]:='*';
  488. xchr[@'53]:='+';
  489. xchr[@'54]:=',';
  490. xchr[@'55]:='-';
  491. xchr[@'56]:='.';
  492. xchr[@'57]:='/';@/
  493. xchr[@'60]:='0';
  494. xchr[@'61]:='1';
  495. xchr[@'62]:='2';
  496. xchr[@'63]:='3';
  497. xchr[@'64]:='4';
  498. xchr[@'65]:='5';
  499. xchr[@'66]:='6';
  500. xchr[@'67]:='7';@/
  501. xchr[@'70]:='8';
  502. xchr[@'71]:='9';
  503. xchr[@'72]:=':';
  504. xchr[@'73]:=';';
  505. xchr[@'74]:='<';
  506. xchr[@'75]:='=';
  507. xchr[@'76]:='>';
  508. xchr[@'77]:='?';@/
  509. xchr[@'100]:='@@';
  510. xchr[@'101]:='A';
  511. xchr[@'102]:='B';
  512. xchr[@'103]:='C';
  513. xchr[@'104]:='D';
  514. xchr[@'105]:='E';
  515. xchr[@'106]:='F';
  516. xchr[@'107]:='G';@/
  517. xchr[@'110]:='H';
  518. xchr[@'111]:='I';
  519. xchr[@'112]:='J';
  520. xchr[@'113]:='K';
  521. xchr[@'114]:='L';
  522. xchr[@'115]:='M';
  523. xchr[@'116]:='N';
  524. xchr[@'117]:='O';@/
  525. xchr[@'120]:='P';
  526. xchr[@'121]:='Q';
  527. xchr[@'122]:='R';
  528. xchr[@'123]:='S';
  529. xchr[@'124]:='T';
  530. xchr[@'125]:='U';
  531. xchr[@'126]:='V';
  532. xchr[@'127]:='W';@/
  533. xchr[@'130]:='X';
  534. xchr[@'131]:='Y';
  535. xchr[@'132]:='Z';
  536. xchr[@'133]:='[';
  537. xchr[@'134]:='\';
  538. xchr[@'135]:=']';
  539. xchr[@'136]:='^';
  540. xchr[@'137]:='_';@/
  541. xchr[@'140]:='`';
  542. xchr[@'141]:='a';
  543. xchr[@'142]:='b';
  544. xchr[@'143]:='c';
  545. xchr[@'144]:='d';
  546. xchr[@'145]:='e';
  547. xchr[@'146]:='f';
  548. xchr[@'147]:='g';@/
  549. xchr[@'150]:='h';
  550. xchr[@'151]:='i';
  551. xchr[@'152]:='j';
  552. xchr[@'153]:='k';
  553. xchr[@'154]:='l';
  554. xchr[@'155]:='m';
  555. xchr[@'156]:='n';
  556. xchr[@'157]:='o';@/
  557. xchr[@'160]:='p';
  558. xchr[@'161]:='q';
  559. xchr[@'162]:='r';
  560. xchr[@'163]:='s';
  561. xchr[@'164]:='t';
  562. xchr[@'165]:='u';
  563. xchr[@'166]:='v';
  564. xchr[@'167]:='w';@/
  565. xchr[@'170]:='x';
  566. xchr[@'171]:='y';
  567. xchr[@'172]:='z';
  568. xchr[@'173]:='{';
  569. xchr[@'174]:='|';
  570. xchr[@'175]:='}';
  571. xchr[@'176]:='~';@/
  572. @ The ASCII code is ``standard'' only to a certain extent, since many
  573. computer installations have found it advantageous to have ready access
  574. to more than 94 printing characters.  If \MF\ is being used
  575. on a garden-variety \PASCAL\ for which only standard ASCII
  576. codes will appear in the input and output files, it doesn't really matter
  577. what codes are specified in |xchr[0..@'37]|, but the safest policy is to
  578. blank everything out by using the code shown below.
  579. However, other settings of |xchr| will make \MF\ more friendly on
  580. computers that have an extended character set, so that users can type things
  581. like `\.^^Z' instead of `\.{<>}'.
  582. People with extended character sets can
  583. assign codes arbitrarily, giving an |xchr| equivalent to whatever
  584. characters the users of \MF\ are allowed to have in their input files.
  585. Appropriate changes to \MF's |char_class| table should then be made.
  586. (Unlike \TeX, each installation of \MF\ has a fixed assignment of category
  587. codes, called the |char_class|.) Such changes make portability of programs
  588. more difficult, so they should be introduced cautiously if at all.
  589. @^character set dependencies@>
  590. @^system dependencies@>
  591. @<Set init...@>=
  592. for i:=0 to @'37 do xchr[i]:=' ';
  593. for i:=@'177 to @'377 do xchr[i]:=' ';
  594. @ The following system-independent code makes the |xord| array contain a
  595. suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]|
  596. where |i<j<@'177|, the value of |xord[xchr[i]]| will turn out to be
  597. |j| or more; hence, standard ASCII code numbers will be used instead of
  598. codes below @'40 in case there is a coincidence.
  599. @<Set init...@>=
  600. for i:=first_text_char to last_text_char do xord[chr(i)]:=@'177;
  601. for i:=@'200 to @'377 do xord[xchr[i]]:=i;
  602. for i:=0 to @'176 do xord[xchr[i]]:=i;
  603. @* \[3] Input and output.
  604. The bane of portability is the fact that different operating systems treat
  605. input and output quite differently, perhaps because computer scientists
  606. have not given sufficient attention to this problem. People have felt somehow
  607. that input and output are not part of ``real'' programming. Well, it is true
  608. that some kinds of programming are more fun than others. With existing
  609. input/output conventions being so diverse and so messy, the only sources of
  610. joy in such parts of the code are the rare occasions when one can find a
  611. way to make the program a little less bad than it might have been. We have
  612. two choices, either to attack I/O now and get it over with, or to postpone
  613. I/O until near the end. Neither prospect is very attractive, so let's
  614. get it over with.
  615. The basic operations we need to do are (1)~inputting and outputting of
  616. text, to or from a file or the user's terminal; (2)~inputting and
  617. outputting of eight-bit bytes, to or from a file; (3)~instructing the
  618. operating system to initiate (``open'') or to terminate (``close'') input or
  619. output from a specified file; (4)~testing whether the end of an input
  620. file has been reached; (5)~display of bits on the user's screen.
  621. The bit-display operation will be discussed in a later section; we shall
  622. deal here only with more traditional kinds of I/O.
  623. \MF\ needs to deal with two kinds of files.
  624. We shall use the term |alpha_file| for a file that contains textual data,
  625. and the term |byte_file| for a file that contains eight-bit binary information.
  626. These two types turn out to be the same on many computers, but
  627. sometimes there is a significant distinction, so we shall be careful to
  628. distinguish between them. Standard protocols for transferring
  629. such files from computer to computer, via high-speed networks, are
  630. now becoming available to more and more communities of users.
  631. The program actually makes use also of a third kind of file, called a
  632. |word_file|, when dumping and reloading base information for its own
  633. initialization.  We shall define a word file later; but it will be possible
  634. for us to specify simple operations on word files before they are defined.
  635. @<Types...@>=
  636. @!eight_bits=0..255; {unsigned one-byte quantity}
  637. @!alpha_file=packed file of text_char; {files that contain textual data}
  638. @!byte_file=packed file of eight_bits; {files that contain binary data}
  639. @ Most of what we need to do with respect to input and output can be handled
  640. by the I/O facilities that are standard in \PASCAL, i.e., the routines
  641. called |get|, |put|, |eof|, and so on. But
  642. standard \PASCAL\ does not allow file variables to be associated with file
  643. names that are determined at run time, so it cannot be used to implement
  644. \MF; some sort of extension to \PASCAL's ordinary |reset| and |rewrite|
  645. is crucial for our purposes. We shall assume that |name_of_file| is a variable
  646. of an appropriate type such that the \PASCAL\ run-time system being used to
  647. implement \MF\ can open a file whose external name is specified by
  648. |name_of_file|.
  649. @^system dependencies@>
  650. @<Glob...@>=
  651. @!name_of_file:packed array[1..file_name_size] of char;@;@/
  652.   {on some systems this may be a \&{record} variable}
  653. @!name_length:0..file_name_size;@/{this many characters are actually
  654.   relevant in |name_of_file| (the rest are blank)}
  655. @ The \ph\ compiler with which the present version of \MF\ was prepared has
  656. extended the rules of \PASCAL\ in a very convenient way. To open file~|f|,
  657. we can write
  658. $$\vbox{\halign{#\hfil\qquad&#\hfil\cr
  659. |reset(f,@t\\{name}@>,'/O')|&for input;\cr
  660. |rewrite(f,@t\\{name}@>,'/O')|&for output.\cr}}$$
  661. The `\\{name}' parameter, which is of type `\ignorespaces|packed
  662. array[@t\<\\{any}>@>] of text_char|', stands for the name of
  663. the external file that is being opened for input or output.
  664. Blank spaces that might appear in \\{name} are ignored.
  665. The `\.{/O}' parameter tells the operating system not to issue its own
  666. error messages if something goes wrong. If a file of the specified name
  667. cannot be found, or if such a file cannot be opened for some other reason
  668. (e.g., someone may already be trying to write the same file), we will have
  669. |@!erstat(f)<>0| after an unsuccessful |reset| or |rewrite|.  This allows
  670. \MF\ to undertake appropriate corrective action.
  671. @:PASCAL H}{\ph@>
  672. @^system dependencies@>
  673. \MF's file-opening procedures return |false| if no file identified by
  674. |name_of_file| could be opened.
  675. @d reset_OK(#)==erstat(#)=0
  676. @d rewrite_OK(#)==erstat(#)=0
  677. @p function a_open_in(var @!f:alpha_file):boolean;
  678.   {open a text file for input}
  679. begin reset(f,name_of_file,'/O'); a_open_in:=reset_OK(f);
  680. function a_open_out(var @!f:alpha_file):boolean;
  681.   {open a text file for output}
  682. begin rewrite(f,name_of_file,'/O'); a_open_out:=rewrite_OK(f);
  683. function b_open_out(var @!f:byte_file):boolean;
  684.   {open a binary file for output}
  685. begin rewrite(f,name_of_file,'/O'); b_open_out:=rewrite_OK(f);
  686. function w_open_in(var @!f:word_file):boolean;
  687.   {open a word file for input}
  688. begin reset(f,name_of_file,'/O'); w_open_in:=reset_OK(f);
  689. function w_open_out(var @!f:word_file):boolean;
  690.   {open a word file for output}
  691. begin rewrite(f,name_of_file,'/O'); w_open_out:=rewrite_OK(f);
  692. @ Files can be closed with the \ph\ routine `|close(f)|', which
  693. @^system dependencies@>
  694. should be used when all input or output with respect to |f| has been completed.
  695. This makes |f| available to be opened again, if desired; and if |f| was used for
  696. output, the |close| operation makes the corresponding external file appear
  697. on the user's area, ready to be read.
  698. @p procedure a_close(var @!f:alpha_file); {close a text file}
  699. begin close(f);
  700. procedure b_close(var @!f:byte_file); {close a binary file}
  701. begin close(f);
  702. procedure w_close(var @!f:word_file); {close a word file}
  703. begin close(f);
  704. @ Binary input and output are done with \PASCAL's ordinary |get| and |put|
  705. procedures, so we don't have to make any other special arrangements for
  706. binary~I/O. Text output is also easy to do with standard \PASCAL\ routines.
  707. The treatment of text input is more difficult, however, because
  708. of the necessary translation to |ASCII_code| values.
  709. \MF's conventions should be efficient, and they should
  710. blend nicely with the user's operating environment.
  711. @ Input from text files is read one line at a time, using a routine called
  712. |input_ln|. This function is defined in terms of global variables called
  713. |buffer|, |first|, and |last| that will be described in detail later; for
  714. now, it suffices for us to know that |buffer| is an array of |ASCII_code|
  715. values, and that |first| and |last| are indices into this array
  716. representing the beginning and ending of a line of text.
  717. @<Glob...@>=
  718. @!buffer:array[0..buf_size] of ASCII_code; {lines of characters being read}
  719. @!first:0..buf_size; {the first unused position in |buffer|}
  720. @!last:0..buf_size; {end of the line just input to |buffer|}
  721. @!max_buf_stack:0..buf_size; {largest index used in |buffer|}
  722. @ The |input_ln| function brings the next line of input from the specified
  723. field into available positions of the buffer array and returns the value
  724. |true|, unless the file has already been entirely read, in which case it
  725. returns |false| and sets |last:=first|.  In general, the |ASCII_code|
  726. numbers that represent the next line of the file are input into
  727. |buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the
  728. global variable |last| is set equal to |first| plus the length of the
  729. line. Trailing blanks are removed from the line; thus, either |last=first|
  730. (in which case the line was entirely blank) or |buffer[last-1]<>" "|.
  731. @^inner loop@>
  732. An overflow error is given, however, if the normal actions of |input_ln|
  733. would make |last>=buf_size|; this is done so that other parts of \MF\
  734. can safely look at the contents of |buffer[last+1]| without overstepping
  735. the bounds of the |buffer| array. Upon entry to |input_ln|, the condition
  736. |first<buf_size| will always hold, so that there is always room for an
  737. ``empty'' line.
  738. The variable |max_buf_stack|, which is used to keep track of how large
  739. the |buf_size| parameter must be to accommodate the present job, is
  740. also kept up to date by |input_ln|.
  741. If the |bypass_eoln| parameter is |true|, |input_ln| will do a |get|
  742. before looking at the first character of the line; this skips over
  743. an |eoln| that was in |f^|. The procedure does not do a |get| when it
  744. reaches the end of the line; therefore it can be used to acquire input
  745. from the user's terminal as well as from ordinary text files.
  746. Standard \PASCAL\ says that a file should have |eoln| immediately
  747. before |eof|, but \MF\ needs only a weaker restriction: If |eof|
  748. occurs in the middle of a line, the system function |eoln| should return
  749. a |true| result (even though |f^| will be undefined).
  750. @p function input_ln(var @!f:alpha_file;@!bypass_eoln:boolean):boolean;
  751.   {inputs the next line or returns |false|}
  752. var @!last_nonblank:0..buf_size; {|last| with trailing blanks removed}
  753. begin if bypass_eoln then if not eof(f) then get(f);
  754.   {input the first character of the line into |f^|}
  755. last:=first; {cf.\ Matthew 19\thinspace:\thinspace30}
  756. if eof(f) then input_ln:=false
  757. else  begin last_nonblank:=first;
  758.   while not eoln(f) do
  759.     begin if last>=max_buf_stack then
  760.       begin max_buf_stack:=last+1;
  761.       if max_buf_stack=buf_size then
  762.         @<Report overflow of the input buffer, and abort@>;
  763.       end;
  764.     buffer[last]:=xord[f^]; get(f); incr(last);
  765.     if buffer[last-1]<>" " then last_nonblank:=last;
  766.     end;
  767.   last:=last_nonblank; input_ln:=true;
  768.   end;
  769. @ The user's terminal acts essentially like other files of text, except
  770. that it is used both for input and for output. When the terminal is
  771. considered an input file, the file variable is called |term_in|, and when it
  772. is considered an output file the file variable is |term_out|.
  773. @^system dependencies@>
  774. @<Glob...@>=
  775. @!term_in:alpha_file; {the terminal as an input file}
  776. @!term_out:alpha_file; {the terminal as an output file}
  777. @ Here is how to open the terminal files
  778. in \ph. The `\.{/I}' switch suppresses the first |get|.
  779. @^system dependencies@>
  780. @d t_open_in==reset(term_in,'TTY:','/O/I') {open the terminal for text input}
  781. @d t_open_out==rewrite(term_out,'TTY:','/O') {open the terminal for text output}
  782. @ Sometimes it is necessary to synchronize the input/output mixture that
  783. happens on the user's terminal, and three system-dependent
  784. procedures are used for this
  785. purpose. The first of these, |update_terminal|, is called when we want
  786. to make sure that everything we have output to the terminal so far has
  787. actually left the computer's internal buffers and been sent.
  788. The second, |clear_terminal|, is called when we wish to cancel any
  789. input that the user may have typed ahead (since we are about to
  790. issue an unexpected error message). The third, |wake_up_terminal|,
  791. is supposed to revive the terminal if the user has disabled it by
  792. some instruction to the operating system.  The following macros show how
  793. these operations can be specified in \ph:
  794. @^system dependencies@>
  795. @d update_terminal == break(term_out) {empty the terminal output buffer}
  796. @d clear_terminal == break_in(term_in,true) {clear the terminal input buffer}
  797. @d wake_up_terminal == do_nothing {cancel the user's cancellation of output}
  798. @ We need a special routine to read the first line of \MF\ input from
  799. the user's terminal. This line is different because it is read before we
  800. have opened the transcript file; there is sort of a ``chicken and
  801. egg'' problem here. If the user types `\.{input cmr10}' on the first
  802. line, or if some macro invoked by that line does such an \.{input},
  803. the transcript file will be named `\.{cmr10.log}'; but if no \.{input}
  804. commands are performed during the first line of terminal input, the transcript
  805. file will acquire its default name `\.{mfput.log}'. (The transcript file
  806. will not contain error messages generated by the first line before the
  807. first \.{input} command.)
  808. The first line is even more special if we are lucky enough to have an operating
  809. system that treats \MF\ differently from a run-of-the-mill \PASCAL\ object
  810. program. It's nice to let the user start running a \MF\ job by typing
  811. a command line like `\.{MF cmr10}'; in such a case, \MF\ will operate
  812. as if the first line of input were `\.{cmr10}', i.e., the first line will
  813. consist of the remainder of the command line, after the part that invoked \MF.
  814. The first line is special also because it may be read before \MF\ has
  815. input a base file. In such cases, normal error messages cannot yet
  816. be given. The following code uses concepts that will be explained later.
  817. (If the \PASCAL\ compiler does not support non-local |@!goto|, the
  818. @^system dependencies@>
  819. statement `|goto final_end|' should be replaced by something that
  820. quietly terminates the program.)
  821. @<Report overflow of the input buffer, and abort@>=
  822. if base_ident=0 then
  823.   begin write_ln(term_out,'Buffer size exceeded!'); goto final_end;
  824. @.Buffer size exceeded@>
  825.   end
  826. else begin cur_input.loc_field:=first; cur_input.limit_field:=last-1;
  827.   overflow("buffer size",buf_size);
  828. @:METAFONT capacity exceeded buffer size}{\quad buffer size@>
  829.   end
  830. @ Different systems have different ways to get started. But regardless of
  831. what conventions are adopted, the routine that initializes the terminal
  832. should satisfy the following specifications:
  833. \yskip\textindent{1)}It should open file |term_in| for input from the
  834.   terminal. (The file |term_out| will already be open for output to the
  835.   terminal.)
  836. \textindent{2)}If the user has given a command line, this line should be
  837.   considered the first line of terminal input. Otherwise the
  838.   user should be prompted with `\.{**}', and the first line of input
  839.   should be whatever is typed in response.
  840. \textindent{3)}The first line of input, which might or might not be a
  841.   command line, should appear in locations |first| to |last-1| of the
  842.   |buffer| array.
  843. \textindent{4)}The global variable |loc| should be set so that the
  844.   character to be read next by \MF\ is in |buffer[loc]|. This
  845.   character should not be blank, and we should have |loc<last|.
  846. \yskip\noindent(It may be necessary to prompt the user several times
  847. before a non-blank line comes in. The prompt is `\.{**}' instead of the
  848. later `\.*' because the meaning is slightly different: `\.{input}' need
  849. not be typed immediately after~`\.{**}'.)
  850. @d loc==cur_input.loc_field {location of first unread character in |buffer|}
  851. @ The following program does the required initialization
  852. without retrieving a possible command line.
  853. It should be clear how to modify this routine to deal with command lines,
  854. if the system permits them.
  855. @^system dependencies@>
  856. @p function init_terminal:boolean; {gets the terminal input started}
  857. label exit;
  858. begin t_open_in;
  859. loop@+begin wake_up_terminal; write(term_out,'**'); update_terminal;
  860. @.**@>
  861.   if not input_ln(term_in,true) then {this shouldn't happen}
  862.     begin write_ln(term_out);
  863.     write(term_out,'! End of file on the terminal... why?');
  864. @.End of file on the terminal@>
  865.     init_terminal:=false; return;
  866.     end;
  867.   loc:=first;
  868.   while (loc<last)and(buffer[loc]=" ") do incr(loc);
  869.   if loc<last then
  870.     begin init_terminal:=true;
  871.     return; {return unless the line was all blank}
  872.     end;
  873.   write_ln(term_out,'Please type the name of your input file.');
  874.   end;
  875. exit:end;
  876. @* \[4] String handling.
  877. Symbolic token names and diagnostic messages are variable-length strings
  878. of eight-bit characters. Since \PASCAL\ does not have a well-developed string
  879. mechanism, \MF\ does all of its string processing by homegrown methods.
  880. Elaborate facilities for dynamic strings are not needed, so all of the
  881. necessary operations can be handled with a simple data structure.
  882. The array |str_pool| contains all of the (eight-bit) ASCII codes in all
  883. of the strings, and the array |str_start| contains indices of the starting
  884. points of each string. Strings are referred to by integer numbers, so that
  885. string number |s| comprises the characters |str_pool[j]| for
  886. |str_start[s]<=j<str_start[s+1]|. Additional integer variables
  887. |pool_ptr| and |str_ptr| indicate the number of entries used so far
  888. in |str_pool| and |str_start|, respectively; locations
  889. |str_pool[pool_ptr]| and |str_start[str_ptr]| are
  890. ready for the next string to be allocated.
  891. String numbers 0 to 255 are reserved for strings that correspond to single
  892. ASCII characters. This is in accordance with the conventions of \.{WEB},
  893. @.WEB@>
  894. which converts single-character strings into the ASCII code number of the
  895. single character involved, while it converts other strings into integers
  896. and builds a string pool file. Thus, when the string constant \.{"."} appears
  897. in the program below, \.{WEB} converts it into the integer 46, which is the
  898. ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"}
  899. into some integer greater than~255. String number 46 will presumably be the
  900. single character `\..'\thinspace; but some ASCII codes have no standard visible
  901. representation, and \MF\ may need to be able to print an arbitrary
  902. ASCII character, so the first 256 strings are used to specify exactly what
  903. should be printed for each of the 256 possibilities.
  904. Elements of the |str_pool| array must be ASCII codes that can actually be
  905. printed; i.e., they must have an |xchr| equivalent in the local
  906. character set. (This restriction applies only to preloaded strings,
  907. not to those generated dynamically by the user.)
  908. Some \PASCAL\ compilers won't pack integers into a single byte unless the
  909. integers lie in the range |-128..127|. To accommodate such systems
  910. we access the string pool only via macros that can easily be redefined.
  911. @d si(#) == # {convert from |ASCII_code| to |packed_ASCII_code|}
  912. @d so(#) == # {convert from |packed_ASCII_code| to |ASCII_code|}
  913. @<Types...@>=
  914. @!pool_pointer = 0..pool_size; {for variables that point into |str_pool|}
  915. @!str_number = 0..max_strings; {for variables that point into |str_start|}
  916. @!packed_ASCII_code = 0..255; {elements of |str_pool| array}
  917. @ @<Glob...@>=
  918. @!str_pool:packed array[pool_pointer] of packed_ASCII_code; {the characters}
  919. @!str_start : array[str_number] of pool_pointer; {the starting pointers}
  920. @!pool_ptr : pool_pointer; {first unused position in |str_pool|}
  921. @!str_ptr : str_number; {number of the current string being created}
  922. @!init_pool_ptr : pool_pointer; {the starting value of |pool_ptr|}
  923. @!init_str_ptr : str_number; {the starting value of |str_ptr|}
  924. @!max_pool_ptr : pool_pointer; {the maximum so far of |pool_ptr|}
  925. @!max_str_ptr : str_number; {the maximum so far of |str_ptr|}
  926. @ Several of the elementary string operations are performed using \.{WEB}
  927. macros instead of \PASCAL\ procedures, because many of the
  928. operations are done quite frequently and we want to avoid the
  929. overhead of procedure calls. For example, here is
  930. a simple macro that computes the length of a string.
  931. @.WEB@>
  932. @d length(#)==(str_start[#+1]-str_start[#]) {the number of characters
  933.   in string number \#}
  934. @ The length of the current string is called |cur_length|:
  935. @d cur_length == (pool_ptr - str_start[str_ptr])
  936. @ Strings are created by appending character codes to |str_pool|.
  937. The |append_char| macro, defined here, does not check to see if the
  938. value of |pool_ptr| has gotten too high; this test is supposed to be
  939. made before |append_char| is used.
  940. To test if there is room to append |l| more characters to |str_pool|,
  941. we shall write |str_room(l)|, which aborts \MF\ and gives an
  942. apologetic error message if there isn't enough room.
  943. @d append_char(#) == {put |ASCII_code| \# at the end of |str_pool|}
  944. begin str_pool[pool_ptr]:=si(#); incr(pool_ptr);
  945. @d str_room(#) == {make sure that the pool hasn't overflowed}
  946.   begin if pool_ptr+# > max_pool_ptr then
  947.     begin if pool_ptr+# > pool_size then
  948.       overflow("pool size",pool_size-init_pool_ptr);
  949. @:METAFONT capacity exceeded pool size}{\quad pool size@>
  950.     max_pool_ptr:=pool_ptr+#;
  951.     end;
  952.   end
  953. @ \MF's string expressions are implemented in a brute-force way: Every
  954. new string or substring that is needed is simply copied into the string pool.
  955. Such a scheme can be justified because string expressions aren't a big
  956. deal in \MF\ applications; strings rarely need to be saved from one
  957. statement to the next. But it would waste space needlessly if we didn't
  958. try to reclaim the space of strings that are going to be used only once.
  959. Therefore a simple reference count mechanism is provided: If there are
  960. @^reference counts@>
  961. no references to a certain string from elsewhere in the program, and
  962. if there are no references to any strings created subsequent to it,
  963. then the string space will be reclaimed.
  964. The number of references to string number |s| will be |str_ref[s]|. The
  965. special value |str_ref[s]=max_str_ref=127| is used to denote an unknown
  966. positive number of references; such strings will never be recycled. If
  967. a string is ever referred to more than 126 times, simultaneously, we
  968. put it in this category. Hence a single byte suffices to store each |str_ref|.
  969. @d max_str_ref=127 {``infinite'' number of references}
  970. @d add_str_ref(#)==begin if str_ref[#]<max_str_ref then incr(str_ref[#]);
  971.   end
  972. @<Glob...@>=
  973. @!str_ref:array[str_number] of 0..max_str_ref;
  974. @ Here's what we do when a string reference disappears:
  975. @d delete_str_ref(#)== begin if str_ref[#]<max_str_ref then
  976.     if str_ref[#]>1 then decr(str_ref[#])@+else flush_string(#);
  977.     end
  978. @<Declare the procedure called |flush_string|@>=
  979. procedure flush_string(@!s:str_number);
  980. begin if s<str_ptr-1 then str_ref[s]:=0
  981. else  repeat decr(str_ptr);
  982.   until str_ref[str_ptr-1]<>0;
  983. pool_ptr:=str_start[str_ptr];
  984. @ Once a sequence of characters has been appended to |str_pool|, it
  985. officially becomes a string when the function |make_string| is called.
  986. This function returns the identification number of the new string as its
  987. value.
  988. @p function make_string : str_number; {current string enters the pool}
  989. begin if str_ptr=max_str_ptr then
  990.   begin if str_ptr=max_strings then
  991.     overflow("number of strings",max_strings-init_str_ptr);
  992. @:METAFONT capacity exceeded number of strings}{\quad number of strings@>
  993.   incr(max_str_ptr);
  994.   end;
  995. str_ref[str_ptr]:=1; incr(str_ptr); str_start[str_ptr]:=pool_ptr;
  996. make_string:=str_ptr-1;
  997. @ The following subroutine compares string |s| with another string of the
  998. same length that appears in |buffer| starting at position |k|;
  999. the result is |true| if and only if the strings are equal.
  1000. @p function str_eq_buf(@!s:str_number;@!k:integer):boolean;
  1001.   {test equality of strings}
  1002. label not_found; {loop exit}
  1003. var @!j: pool_pointer; {running index}
  1004. @!result: boolean; {result of comparison}
  1005. begin j:=str_start[s];
  1006. while j<str_start[s+1] do
  1007.   begin if so(str_pool[j])<>buffer[k] then
  1008.     begin result:=false; goto not_found;
  1009.     end;
  1010.   incr(j); incr(k);
  1011.   end;
  1012. result:=true;
  1013. not_found: str_eq_buf:=result;
  1014. @ Here is a similar routine, but it compares two strings in the string pool,
  1015. and it does not assume that they have the same length. If the first string
  1016. is lexicographically greater than, less than, or equal to the second,
  1017. the result is respectively positive, negative, or zero.
  1018. @p function str_vs_str(@!s,@!t:str_number):integer;
  1019.   {test equality of strings}
  1020. label exit;
  1021. var @!j,@!k: pool_pointer; {running indices}
  1022. @!ls,@!lt:integer; {lengths}
  1023. @!l:integer; {length remaining to test}
  1024. begin ls:=length(s); lt:=length(t);
  1025. if ls<=lt then l:=ls@+else l:=lt;
  1026. j:=str_start[s]; k:=str_start[t];
  1027. while l>0 do
  1028.   begin if str_pool[j]<>str_pool[k] then
  1029.     begin str_vs_str:=str_pool[j]-str_pool[k]; return;
  1030.     end;
  1031.   incr(j); incr(k); decr(l);
  1032.   end;
  1033. str_vs_str:=ls-lt;
  1034. exit:end;
  1035. @ The initial values of |str_pool|, |str_start|, |pool_ptr|,
  1036. and |str_ptr| are computed by the \.{INIMF} program, based in part
  1037. on the information that \.{WEB} has output while processing \MF.
  1038. @.INIMF@>
  1039. @^string pool@>
  1040. @p @!init function get_strings_started:boolean; {initializes the string pool,
  1041.   but returns |false| if something goes wrong}
  1042. label done,exit;
  1043. var @!k,@!l:0..255; {small indices or counters}
  1044. @!m,@!n:text_char; {characters input from |pool_file|}
  1045. @!g:str_number; {garbage}
  1046. @!a:integer; {accumulator for check sum}
  1047. @!c:boolean; {check sum has been checked}
  1048. begin pool_ptr:=0; str_ptr:=0; max_pool_ptr:=0; max_str_ptr:=0; str_start[0]:=0;
  1049. @<Make the first 256 strings@>;
  1050. @<Read the other strings from the \.{MF.POOL} file and return |true|,
  1051.   or give an error message and return |false|@>;
  1052. exit:end;
  1053. @ @d app_lc_hex(#)==l:=#;
  1054.   if l<10 then append_char(l+"0")@+else append_char(l-10+"a")
  1055. @<Make the first 256...@>=
  1056. for k:=0 to 255 do
  1057.   begin if (@<Character |k| cannot be printed@>) then
  1058.     begin append_char("^"); append_char("^");
  1059.     if k<@'100 then append_char(k+@'100)
  1060.     else if k<@'200 then append_char(k-@'100)
  1061.     else begin app_lc_hex(k div 16); app_lc_hex(k mod 16);
  1062.       end;
  1063.     end
  1064.   else append_char(k);
  1065.   g:=make_string; str_ref[g]:=max_str_ref;
  1066.   end
  1067. @ The first 128 strings will contain 95 standard ASCII characters, and the
  1068. other 33 characters will be printed in three-symbol form like `\.{\^\^A}'
  1069. unless a system-dependent change is made here. Installations that have
  1070. an extended character set, where for example |xchr[@'32]=@t\.{\'^^Z\'}@>|,
  1071. would like string @'32 to be the single character @'32 instead of the
  1072. three characters @'136, @'136, @'132 (\.{\^\^Z}). On the other hand,
  1073. even people with an extended character set will want to represent string
  1074. @'15 by \.{\^\^M}, since @'15 is ASCII's ``carriage return'' code; the idea is
  1075. to produce visible strings instead of tabs or line-feeds or carriage-returns
  1076. or bell-rings or characters that are treated anomalously in text files.
  1077. Unprintable characters of codes 128--255 are, similarly, rendered
  1078. \.{\^\^80}--\.{\^\^ff}.
  1079. The boolean expression defined here should be |true| unless \MF\ internal
  1080. code number~|k| corresponds to a non-troublesome visible symbol in the
  1081. local character set.
  1082. If character |k| cannot be printed, and |k<@'200|, then character |k+@'100| or
  1083. |k-@'100| must be printable; moreover, ASCII codes |[@'60..@'71, @'141..@'146]|
  1084. must be printable.
  1085. @^character set dependencies@>
  1086. @^system dependencies@>
  1087. @<Character |k| cannot be printed@>=
  1088.   (k<" ")or(k>"~")
  1089. @ When the \.{WEB} system program called \.{TANGLE} processes the \.{MF.WEB}
  1090. description that you are now reading, it outputs the \PASCAL\ program
  1091. \.{MF.PAS} and also a string pool file called \.{MF.POOL}. The \.{INIMF}
  1092. @.WEB@>@.INIMF@>
  1093. program reads the latter file, where each string appears as a two-digit decimal
  1094. length followed by the string itself, and the information is recorded in
  1095. \MF's string memory.
  1096. @<Glob...@>=
  1097. @!init @!pool_file:alpha_file; {the string-pool file output by \.{TANGLE}}
  1098. @ @d bad_pool(#)==begin wake_up_terminal; write_ln(term_out,#);
  1099.   a_close(pool_file); get_strings_started:=false; return;
  1100.   end
  1101. @<Read the other strings...@>=
  1102. name_of_file:=pool_name; {we needn't set |name_length|}
  1103. if a_open_in(pool_file) then
  1104.   begin c:=false;
  1105.   repeat @<Read one string, but return |false| if the
  1106.     string memory space is getting too tight for comfort@>;
  1107.   until c;
  1108.   a_close(pool_file); get_strings_started:=true;
  1109.   end
  1110. else  bad_pool('! I can''t read MF.POOL.')
  1111. @.I can't read MF.POOL@>
  1112. @ @<Read one string...@>=
  1113. begin if eof(pool_file) then bad_pool('! MF.POOL has no check sum.');
  1114. @.MF.POOL has no check sum@>
  1115. read(pool_file,m,n); {read two digits of string length}
  1116. if m='*' then @<Check the pool check sum@>
  1117. else  begin if (xord[m]<"0")or(xord[m]>"9")or@|
  1118.       (xord[n]<"0")or(xord[n]>"9") then
  1119.     bad_pool('! MF.POOL line doesn''t begin with two digits.');
  1120. @.MF.POOL line doesn't...@>
  1121.   l:=xord[m]*10+xord[n]-"0"*11; {compute the length}
  1122.   if pool_ptr+l+string_vacancies>pool_size then
  1123.     bad_pool('! You have to increase POOLSIZE.');
  1124. @.You have to increase POOLSIZE@>
  1125.   for k:=1 to l do
  1126.     begin if eoln(pool_file) then m:=' '@+else read(pool_file,m);
  1127.     append_char(xord[m]);
  1128.     end;
  1129.   read_ln(pool_file); g:=make_string; str_ref[g]:=max_str_ref;
  1130.   end;
  1131. @ The \.{WEB} operation \.{@@\$} denotes the value that should be at the
  1132. end of this \.{MF.POOL} file; any other value means that the wrong pool
  1133. file has been loaded.
  1134. @^check sum@>
  1135. @<Check the pool check sum@>=
  1136. begin a:=0; k:=1;
  1137. loop@+  begin if (xord[n]<"0")or(xord[n]>"9") then
  1138.   bad_pool('! MF.POOL check sum doesn''t have nine digits.');
  1139. @.MF.POOL check sum...@>
  1140.   a:=10*a+xord[n]-"0";
  1141.   if k=9 then goto done;
  1142.   incr(k); read(pool_file,n);
  1143.   end;
  1144. done: if a<>@$ then bad_pool('! MF.POOL doesn''t match; TANGLE me again.');
  1145. @.MF.POOL doesn't match@>
  1146. c:=true;
  1147. @* \[5] On-line and off-line printing.
  1148. Messages that are sent to a user's terminal and to the transcript-log file
  1149. are produced by several `|print|' procedures. These procedures will
  1150. direct their output to a variety of places, based on the setting of
  1151. the global variable |selector|, which has the following possible
  1152. values:
  1153. \yskip
  1154. \hang |term_and_log|, the normal setting, prints on the terminal and on the
  1155.   transcript file.
  1156. \hang |log_only|, prints only on the transcript file.
  1157. \hang |term_only|, prints only on the terminal.
  1158. \hang |no_print|, doesn't print at all. This is used only in rare cases
  1159.   before the transcript file is open.
  1160. \hang |pseudo|, puts output into a cyclic buffer that is used
  1161.   by the |show_context| routine; when we get to that routine we shall discuss
  1162.   the reasoning behind this curious mode.
  1163. \hang |new_string|, appends the output to the current string in the
  1164.   string pool.
  1165. \yskip
  1166. \noindent The symbolic names `|term_and_log|', etc., have been assigned
  1167. numeric codes that satisfy the convenient relations |no_print+1=term_only|,
  1168. |no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|.
  1169. Three additional global variables, |tally| and |term_offset| and
  1170. |file_offset|, record the number of characters that have been printed
  1171. since they were most recently cleared to zero. We use |tally| to record
  1172. the length of (possibly very long) stretches of printing; |term_offset|
  1173. and |file_offset|, on the other hand, keep track of how many characters
  1174. have appeared so far on the current line that has been output to the
  1175. terminal or to the transcript file, respectively.
  1176. @d no_print=0 {|selector| setting that makes data disappear}
  1177. @d term_only=1 {printing is destined for the terminal only}
  1178. @d log_only=2 {printing is destined for the transcript file only}
  1179. @d term_and_log=3 {normal |selector| setting}
  1180. @d pseudo=4 {special |selector| setting for |show_context|}
  1181. @d new_string=5 {printing is deflected to the string pool}
  1182. @d max_selector=5 {highest selector setting}
  1183. @<Glob...@>=
  1184. @!log_file : alpha_file; {transcript of \MF\ session}
  1185. @!selector : 0..max_selector; {where to print a message}
  1186. @!dig : array[0..22] of 0..15; {digits in a number being output}
  1187. @!tally : integer; {the number of characters recently printed}
  1188. @!term_offset : 0..max_print_line;
  1189.   {the number of characters on the current terminal line}
  1190. @!file_offset : 0..max_print_line;
  1191.   {the number of characters on the current file line}
  1192. @!trick_buf:array[0..error_line] of ASCII_code; {circular buffer for
  1193.   pseudoprinting}
  1194. @!trick_count: integer; {threshold for pseudoprinting, explained later}
  1195. @!first_count: integer; {another variable for pseudoprinting}
  1196. @ @<Initialize the output routines@>=
  1197. selector:=term_only; tally:=0; term_offset:=0; file_offset:=0;
  1198. @ Macro abbreviations for output to the terminal and to the log file are
  1199. defined here for convenience. Some systems need special conventions
  1200. for terminal output, and it is possible to adhere to those conventions
  1201. by changing |wterm|, |wterm_ln|, and |wterm_cr| here.
  1202. @^system dependencies@>
  1203. @d wterm(#)==write(term_out,#)
  1204. @d wterm_ln(#)==write_ln(term_out,#)
  1205. @d wterm_cr==write_ln(term_out)
  1206. @d wlog(#)==write(log_file,#)
  1207. @d wlog_ln(#)==write_ln(log_file,#)
  1208. @d wlog_cr==write_ln(log_file)
  1209. @ To end a line of text output, we call |print_ln|.
  1210. @<Basic print...@>=
  1211. procedure print_ln; {prints an end-of-line}
  1212. begin case selector of
  1213. term_and_log: begin wterm_cr; wlog_cr;
  1214.   term_offset:=0; file_offset:=0;
  1215.   end;
  1216. log_only: begin wlog_cr; file_offset:=0;
  1217.   end;
  1218. term_only: begin wterm_cr; term_offset:=0;
  1219.   end;
  1220. no_print,pseudo,new_string: do_nothing;
  1221. end; {there are no other cases}
  1222. end; {note that |tally| is not affected}
  1223. @ The |print_char| procedure sends one character to the desired destination,
  1224. using the |xchr| array to map it into an external character compatible with
  1225. |input_ln|. All printing comes through |print_ln| or |print_char|.
  1226. @<Basic printing...@>=
  1227. procedure print_char(@!s:ASCII_code); {prints a single character}
  1228. begin case selector of
  1229. term_and_log: begin wterm(xchr[s]); wlog(xchr[s]);
  1230.   incr(term_offset); incr(file_offset);
  1231.   if term_offset=max_print_line then
  1232.     begin wterm_cr; term_offset:=0;
  1233.     end;
  1234.   if file_offset=max_print_line then
  1235.     begin wlog_cr; file_offset:=0;
  1236.     end;
  1237.   end;
  1238. log_only: begin wlog(xchr[s]); incr(file_offset);
  1239.   if file_offset=max_print_line then print_ln;
  1240.   end;
  1241. term_only: begin wterm(xchr[s]); incr(term_offset);
  1242.   if term_offset=max_print_line then print_ln;
  1243.   end;
  1244. no_print: do_nothing;
  1245. pseudo: if tally<trick_count then trick_buf[tally mod error_line]:=s;
  1246. new_string: begin if pool_ptr<pool_size then append_char(s);
  1247.   end; {we drop characters if the string space is full}
  1248. end; {there are no other cases}
  1249. incr(tally);
  1250. @ An entire string is output by calling |print|. Note that if we are outputting
  1251. the single standard ASCII character \.c, we could call |print("c")|, since
  1252. |"c"=99| is the number of a single-character string, as explained above. But
  1253. |print_char("c")| is quicker, so \MF\ goes directly to the |print_char|
  1254. routine when it knows that this is safe. (The present implementation
  1255. assumes that it is always safe to print a visible ASCII character.)
  1256. @^system dependencies@>
  1257. @<Basic print...@>=
  1258. procedure print(@!s:integer); {prints string |s|}
  1259. var @!j:pool_pointer; {current character code position}
  1260. begin if (s<0)or(s>=str_ptr) then s:="???"; {this can't happen}
  1261. @.???@>
  1262. if (s<256)and(selector>pseudo) then print_char(s)
  1263. else begin j:=str_start[s];
  1264.   while j<str_start[s+1] do
  1265.     begin print_char(so(str_pool[j])); incr(j);
  1266.     end;
  1267.   end;
  1268. @ Sometimes it's necessary to print a string whose characters
  1269. may not be visible ASCII codes. In that case |slow_print| is used.
  1270. @<Basic print...@>=
  1271. procedure slow_print(@!s:integer); {prints string |s|}
  1272. var @!j:pool_pointer; {current character code position}
  1273. begin if (s<0)or(s>=str_ptr) then s:="???"; {this can't happen}
  1274. @.???@>
  1275. if (s<256)and(selector>pseudo) then print_char(s)
  1276. else begin j:=str_start[s];
  1277.   while j<str_start[s+1] do
  1278.     begin print(so(str_pool[j])); incr(j);
  1279.     end;
  1280.   end;
  1281. @ Here is the very first thing that \MF\ prints: a headline that identifies
  1282. the version number and base name. The |term_offset| variable is temporarily
  1283. incorrect, but the discrepancy is not serious since we assume that the banner
  1284. and base identifier together will occupy at most |max_print_line|
  1285. character positions.
  1286. @<Initialize the output...@>=
  1287. wterm(banner);
  1288. if base_ident=0 then wterm_ln(' (no base preloaded)')
  1289. else  begin slow_print(base_ident); print_ln;
  1290.   end;
  1291. update_terminal;
  1292. @ The procedure |print_nl| is like |print|, but it makes sure that the
  1293. string appears at the beginning of a new line.
  1294. @<Basic print...@>=
  1295. procedure print_nl(@!s:str_number); {prints string |s| at beginning of line}
  1296. begin if ((term_offset>0)and(odd(selector)))or@|
  1297.   ((file_offset>0)and(selector>=log_only)) then print_ln;
  1298. print(s);
  1299. @ An array of digits in the range |0..9| is printed by |print_the_digs|.
  1300. @<Basic print...@>=
  1301. procedure print_the_digs(@!k:eight_bits);
  1302.   {prints |dig[k-1]|$\,\ldots\,$|dig[0]|}
  1303. begin while k>0 do
  1304.   begin decr(k); print_char("0"+dig[k]);
  1305.   end;
  1306. @ The following procedure, which prints out the decimal representation of a
  1307. given integer |n|, has been written carefully so that it works properly
  1308. if |n=0| or if |(-n)| would cause overflow. It does not apply |mod| or |div|
  1309. to negative arguments, since such operations are not implemented consistently
  1310. by all \PASCAL\ compilers.
  1311. @<Basic print...@>=
  1312. procedure print_int(@!n:integer); {prints an integer in decimal form}
  1313. var k:0..23; {index to current digit; we assume that $|n|<10^{23}$}
  1314. @!m:integer; {used to negate |n| in possibly dangerous cases}
  1315. begin k:=0;
  1316. if n<0 then
  1317.   begin print_char("-");
  1318.   if n>-100000000 then negate(n)
  1319.   else  begin m:=-1-n; n:=m div 10; m:=(m mod 10)+1; k:=1;
  1320.     if m<10 then dig[0]:=m
  1321.     else  begin dig[0]:=0; incr(n);
  1322.       end;
  1323.     end;
  1324.   end;
  1325. repeat dig[k]:=n mod 10; n:=n div 10; incr(k);
  1326. until n=0;
  1327. print_the_digs(k);
  1328. @ \MF\ also makes use of a trivial procedure to print two digits. The
  1329. following subroutine is usually called with a parameter in the range |0<=n<=99|.
  1330. @p procedure print_dd(@!n:integer); {prints two least significant digits}
  1331. begin n:=abs(n) mod 100; print_char("0"+(n div 10));
  1332. print_char("0"+(n mod 10));
  1333. @ Here is a procedure that asks the user to type a line of input,
  1334. assuming that the |selector| setting is either |term_only| or |term_and_log|.
  1335. The input is placed into locations |first| through |last-1| of the
  1336. |buffer| array, and echoed on the transcript file if appropriate.
  1337. This procedure is never called when |interaction<scroll_mode|.
  1338. @d prompt_input(#)==begin wake_up_terminal; print(#); term_input;
  1339.     end {prints a string and gets a line of input}
  1340. @p procedure term_input; {gets a line from the terminal}
  1341. var @!k:0..buf_size; {index into |buffer|}
  1342. begin update_terminal; {Now the user sees the prompt for sure}
  1343. if not input_ln(term_in,true) then fatal_error("End of file on the terminal!");
  1344. @.End of file on the terminal@>
  1345. term_offset:=0; {the user's line ended with \<\rm return>}
  1346. decr(selector); {prepare to echo the input}
  1347. if last<>first then for k:=first to last-1 do print(buffer[k]);
  1348. print_ln; buffer[last]:="%"; incr(selector); {restore previous status}
  1349. @* \[6] Reporting errors.
  1350. When something anomalous is detected, \MF\ typically does something like this:
  1351. $$\vbox{\halign{#\hfil\cr
  1352. |print_err("Something anomalous has been detected");|\cr
  1353. |help3("This is the first line of my offer to help.")|\cr
  1354. |("This is the second line. I'm trying to")|\cr
  1355. |("explain the best way for you to proceed.");|\cr
  1356. |error;|\cr}}$$
  1357. A two-line help message would be given using |help2|, etc.; these informal
  1358. helps should use simple vocabulary that complements the words used in the
  1359. official error message that was printed. (Outside the U.S.A., the help
  1360. messages should preferably be translated into the local vernacular. Each
  1361. line of help is at most 60 characters long, in the present implementation,
  1362. so that |max_print_line| will not be exceeded.)
  1363. The |print_err| procedure supplies a `\.!' before the official message,
  1364. and makes sure that the terminal is awake if a stop is going to occur.
  1365. The |error| procedure supplies a `\..' after the official message, then it
  1366. shows the location of the error; and if |interaction=error_stop_mode|,
  1367. it also enters into a dialog with the user, during which time the help
  1368. message may be printed.
  1369. @^system dependencies@>
  1370. @ The global variable |interaction| has four settings, representing increasing
  1371. amounts of user interaction:
  1372. @d batch_mode=0 {omits all stops and omits terminal output}
  1373. @d nonstop_mode=1 {omits all stops}
  1374. @d scroll_mode=2 {omits error stops}
  1375. @d error_stop_mode=3 {stops at every opportunity to interact}
  1376. @d print_err(#)==begin if interaction=error_stop_mode then wake_up_terminal;
  1377.   print_nl("! "); print(#);
  1378. @.!\relax@>
  1379.   end
  1380. @<Glob...@>=
  1381. @!interaction:batch_mode..error_stop_mode; {current level of interaction}
  1382. @ @<Set init...@>=interaction:=error_stop_mode;
  1383. @ \MF\ is careful not to call |error| when the print |selector| setting
  1384. might be unusual. The only possible values of |selector| at the time of
  1385. error messages are
  1386. \yskip\hang|no_print| (when |interaction=batch_mode|
  1387.   and |log_file| not yet open);
  1388. \hang|term_only| (when |interaction>batch_mode| and |log_file| not yet open);
  1389. \hang|log_only| (when |interaction=batch_mode| and |log_file| is open);
  1390. \hang|term_and_log| (when |interaction>batch_mode| and |log_file| is open).
  1391. @<Initialize the print |selector| based on |interaction|@>=
  1392. if interaction=batch_mode then selector:=no_print@+else selector:=term_only
  1393. @ A global variable |deletions_allowed| is set |false| if the |get_next|
  1394. routine is active when |error| is called; this ensures that |get_next|
  1395. will never be called recursively.
  1396. @^recursion@>
  1397. The global variable |history| records the worst level of error that
  1398. has been detected. It has four possible values: |spotless|, |warning_issued|,
  1399. |error_message_issued|, and |fatal_error_stop|.
  1400. Another global variable, |error_count|, is increased by one when an
  1401. |error| occurs without an interactive dialog, and it is reset to zero at
  1402. the end of every statement.  If |error_count| reaches 100, \MF\ decides
  1403. that there is no point in continuing further.
  1404. @d spotless=0 {|history| value when nothing has been amiss yet}
  1405. @d warning_issued=1 {|history| value when |begin_diagnostic| has been called}
  1406. @d error_message_issued=2 {|history| value when |error| has been called}
  1407. @d fatal_error_stop=3 {|history| value when termination was premature}
  1408. @<Glob...@>=
  1409. @!deletions_allowed:boolean; {is it safe for |error| to call |get_next|?}
  1410. @!history:spotless..fatal_error_stop; {has the source input been clean so far?}
  1411. @!error_count:-1..100; {the number of scrolled errors since the
  1412.   last statement ended}
  1413. @ The value of |history| is initially |fatal_error_stop|, but it will
  1414. be changed to |spotless| if \MF\ survives the initialization process.
  1415. @<Set init...@>=
  1416. deletions_allowed:=true; error_count:=0; {|history| is initialized elsewhere}
  1417. @ Since errors can be detected almost anywhere in \MF, we want to declare the
  1418. error procedures near the beginning of the program. But the error procedures
  1419. in turn use some other procedures, which need to be declared |forward|
  1420. before we get to |error| itself.
  1421. It is possible for |error| to be called recursively if some error arises
  1422. when |get_next| is being used to delete a token, and/or if some fatal error
  1423. occurs while \MF\ is trying to fix a non-fatal one. But such recursion
  1424. @^recursion@>
  1425. is never more than two levels deep.
  1426. @<Error handling...@>=
  1427. procedure@?normalize_selector; forward;@t\2@>@/
  1428. procedure@?get_next; forward;@t\2@>@/
  1429. procedure@?term_input; forward;@t\2@>@/
  1430. procedure@?show_context; forward;@t\2@>@/
  1431. procedure@?begin_file_reading; forward;@t\2@>@/
  1432. procedure@?open_log_file; forward;@t\2@>@/
  1433. procedure@?close_files_and_terminate; forward;@t\2@>@/
  1434. procedure@?clear_for_error_prompt; forward;@t\2@>@/
  1435. @t\4\hskip-\fontdimen2\font@>@;@+@!debug@+procedure@?debug_help;
  1436.   forward;@;@+gubed@;@/
  1437. @t\4@>@<Declare the procedure called |flush_string|@>
  1438. @ Individual lines of help are recorded in the array |help_line|, which
  1439. contains entries in positions |0..(help_ptr-1)|. They should be printed
  1440. in reverse order, i.e., with |help_line[0]| appearing last.
  1441. @d hlp1(#)==help_line[0]:=#;@+end
  1442. @d hlp2(#)==help_line[1]:=#; hlp1
  1443. @d hlp3(#)==help_line[2]:=#; hlp2
  1444. @d hlp4(#)==help_line[3]:=#; hlp3
  1445. @d hlp5(#)==help_line[4]:=#; hlp4
  1446. @d hlp6(#)==help_line[5]:=#; hlp5
  1447. @d help0==help_ptr:=0 {sometimes there might be no help}
  1448. @d help1==@+begin help_ptr:=1; hlp1 {use this with one help line}
  1449. @d help2==@+begin help_ptr:=2; hlp2 {use this with two help lines}
  1450. @d help3==@+begin help_ptr:=3; hlp3 {use this with three help lines}
  1451. @d help4==@+begin help_ptr:=4; hlp4 {use this with four help lines}
  1452. @d help5==@+begin help_ptr:=5; hlp5 {use this with five help lines}
  1453. @d help6==@+begin help_ptr:=6; hlp6 {use this with six help lines}
  1454. @<Glob...@>=
  1455. @!help_line:array[0..5] of str_number; {helps for the next |error|}
  1456. @!help_ptr:0..6; {the number of help lines present}
  1457. @!use_err_help:boolean; {should the |err_help| string be shown?}
  1458. @!err_help:str_number; {a string set up by \&{errhelp}}
  1459. @ @<Set init...@>=
  1460. help_ptr:=0; use_err_help:=false; err_help:=0;
  1461. @ The |jump_out| procedure just cuts across all active procedure levels and
  1462. goes to |end_of_MF|. This is the only nontrivial |@!goto| statement in the
  1463. whole program. It is used when there is no recovery from a particular error.
  1464. Some \PASCAL\ compilers do not implement non-local |goto| statements.
  1465. @^system dependencies@>
  1466. In such cases the body of |jump_out| should simply be
  1467. `|close_files_and_terminate|;\thinspace' followed by a call on some system
  1468. procedure that quietly terminates the program.
  1469. @<Error hand...@>=
  1470. procedure jump_out;
  1471. begin goto end_of_MF;
  1472. @ Here now is the general |error| routine.
  1473. @<Error hand...@>=
  1474. procedure error; {completes the job of error reporting}
  1475. label continue,exit;
  1476. var @!c:ASCII_code; {what the user types}
  1477. @!s1,@!s2,@!s3:integer; {used to save global variables when deleting tokens}
  1478. @!j:pool_pointer; {character position being printed}
  1479. begin if history<error_message_issued then history:=error_message_issued;
  1480. print_char("."); show_context;
  1481. if interaction=error_stop_mode then @<Get user's advice and |return|@>;
  1482. incr(error_count);
  1483. if error_count=100 then
  1484.   begin print_nl("(That makes 100 errors; please try again.)");
  1485. @.That makes 100 errors...@>
  1486.   history:=fatal_error_stop; jump_out;
  1487.   end;
  1488. @<Put help message on the transcript file@>;
  1489. exit:end;
  1490. @ @<Get user's advice...@>=
  1491. loop@+begin continue: clear_for_error_prompt; prompt_input("? ");
  1492. @.?\relax@>
  1493.   if last=first then return;
  1494.   c:=buffer[first];
  1495.   if c>="a" then c:=c+"A"-"a"; {convert to uppercase}
  1496.   @<Interpret code |c| and |return| if done@>;
  1497.   end
  1498. @ It is desirable to provide an `\.E' option here that gives the user
  1499. an easy way to return from \MF\ to the system editor, with the offending
  1500. line ready to be edited. But such an extension requires some system
  1501. wizardry, so the present implementation simply types out the name of the
  1502. file that should be
  1503. edited and the relevant line number.
  1504. @^system dependencies@>
  1505. There is a secret `\.D' option available when the debugging routines haven't
  1506. been commented~out.
  1507. @^debugging@>
  1508. @<Interpret code |c| and |return| if done@>=
  1509. case c of
  1510. "0","1","2","3","4","5","6","7","8","9": if deletions_allowed then
  1511.   @<Delete |c-"0"| tokens and |goto continue|@>;
  1512. @t\4\4@>@;@+@!debug "D":begin debug_help;goto continue;@+end;@+gubed@/
  1513. "E": if file_ptr>0 then
  1514.   begin print_nl("You want to edit file ");
  1515. @.You want to edit file x@>
  1516.   slow_print(input_stack[file_ptr].name_field);
  1517.   print(" at line "); print_int(line);@/
  1518.   interaction:=scroll_mode; jump_out;
  1519.   end;
  1520. "H": @<Print the help information and |goto continue|@>;
  1521. "I":@<Introduce new material from the terminal and |return|@>;
  1522. "Q","R","S":@<Change the interaction level and |return|@>;
  1523. "X":begin interaction:=scroll_mode; jump_out;
  1524.   end;
  1525. othercases do_nothing
  1526. endcases;@/
  1527. @<Print the menu of available options@>
  1528. @ @<Print the menu...@>=
  1529. begin print("Type <return> to proceed, S to scroll future error messages,");@/
  1530. @.Type <return> to proceed...@>
  1531. print_nl("R to run without stopping, Q to run quietly,");@/
  1532. print_nl("I to insert something, ");
  1533. if file_ptr>0 then print("E to edit your file,");
  1534. if deletions_allowed then
  1535.   print_nl("1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
  1536. print_nl("H for help, X to quit.");
  1537. @ Here the author of \MF\ apologizes for making use of the numerical
  1538. relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings
  1539. |batch_mode|, |nonstop_mode|, |scroll_mode|.
  1540. @^Knuth, Donald Ervin@>
  1541. @<Change the interaction...@>=
  1542. begin error_count:=0; interaction:=batch_mode+c-"Q";
  1543. print("OK, entering ");
  1544. case c of
  1545. "Q":begin print("batchmode"); decr(selector);
  1546.   end;
  1547. "R":print("nonstopmode");
  1548. "S":print("scrollmode");
  1549. end; {there are no other cases}
  1550. print("..."); print_ln; update_terminal; return;
  1551. @ When the following code is executed, |buffer[(first+1)..(last-1)]| may
  1552. contain the material inserted by the user; otherwise another prompt will
  1553. be given. In order to understand this part of the program fully, you need
  1554. to be familiar with \MF's input stacks.
  1555. @<Introduce new material...@>=
  1556. begin begin_file_reading; {enter a new syntactic level for terminal input}
  1557. if last>first+1 then
  1558.   begin loc:=first+1; buffer[first]:=" ";
  1559.   end
  1560. else  begin prompt_input("insert>"); loc:=first;
  1561. @.insert>@>
  1562.   end;
  1563. first:=last+1; cur_input.limit_field:=last; return;
  1564. @ We allow deletion of up to 99 tokens at a time.
  1565. @<Delete |c-"0"| tokens...@>=
  1566. begin s1:=cur_cmd; s2:=cur_mod; s3:=cur_sym; OK_to_interrupt:=false;
  1567. if (last>first+1) and (buffer[first+1]>="0")and(buffer[first+1]<="9") then
  1568.   c:=c*10+buffer[first+1]-"0"*11
  1569. else c:=c-"0";
  1570. while c>0 do
  1571.   begin get_next; {one-level recursive call of |error| is possible}
  1572.   @<Decrease the string reference count, if the current token is a string@>;
  1573.   decr(c);
  1574.   end;
  1575. cur_cmd:=s1; cur_mod:=s2; cur_sym:=s3; OK_to_interrupt:=true;
  1576. help2("I have just deleted some text, as you asked.")@/
  1577. ("You can now delete more, or insert, or whatever.");
  1578. show_context; goto continue;
  1579. @ @<Print the help info...@>=
  1580. begin if use_err_help then
  1581.   begin @<Print the string |err_help|, possibly on several lines@>;
  1582.   use_err_help:=false;
  1583.   end
  1584. else  begin if help_ptr=0 then
  1585.     help2("Sorry, I don't know how to help in this situation.")@/
  1586.     @t\kern1em@>("Maybe you should try asking a human?");
  1587.   repeat decr(help_ptr); print(help_line[help_ptr]); print_ln;
  1588.   until help_ptr=0;
  1589.   end;
  1590. help4("Sorry, I already gave what help I could...")@/
  1591.   ("Maybe you should try asking a human?")@/
  1592.   ("An error might have occurred before I noticed any problems.")@/
  1593.   ("``If all else fails, read the instructions.''");@/
  1594. goto continue;
  1595. @ @<Print the string |err_help|, possibly on several lines@>=
  1596. j:=str_start[err_help];
  1597. while j<str_start[err_help+1] do
  1598.   begin if str_pool[j]<>si("%") then print(so(str_pool[j]))
  1599.   else if j+1=str_start[err_help+1] then print_ln
  1600.   else if str_pool[j+1]<>si("%") then print_ln
  1601.   else  begin incr(j); print_char("%");
  1602.     end;
  1603.   incr(j);
  1604.   end
  1605. @ @<Put help message on the transcript file@>=
  1606. if interaction>batch_mode then decr(selector); {avoid terminal output}
  1607. if use_err_help then
  1608.   begin print_nl("");
  1609.   @<Print the string |err_help|, possibly on several lines@>;
  1610.   end
  1611. else while help_ptr>0 do
  1612.   begin decr(help_ptr); print_nl(help_line[help_ptr]);
  1613.   end;
  1614. print_ln;
  1615. if interaction>batch_mode then incr(selector); {re-enable terminal output}
  1616. print_ln
  1617. @ In anomalous cases, the print selector might be in an unknown state;
  1618. the following subroutine is called to fix things just enough to keep
  1619. running a bit longer.
  1620. @p procedure normalize_selector;
  1621. begin if log_opened then selector:=term_and_log
  1622. else selector:=term_only;
  1623. if job_name=0 then open_log_file;
  1624. if interaction=batch_mode then decr(selector);
  1625. @ The following procedure prints \MF's last words before dying.
  1626. @d succumb==begin if interaction=error_stop_mode then
  1627.     interaction:=scroll_mode; {no more interaction}
  1628.   if log_opened then error;
  1629.   @!debug if interaction>batch_mode then debug_help;@;@+gubed@;@/
  1630.   history:=fatal_error_stop; jump_out; {irrecoverable error}
  1631.   end
  1632. @<Error hand...@>=
  1633. procedure fatal_error(@!s:str_number); {prints |s|, and that's it}
  1634. begin normalize_selector;@/
  1635. print_err("Emergency stop"); help1(s); succumb;
  1636. @.Emergency stop@>
  1637. @ Here is the most dreaded error message.
  1638. @<Error hand...@>=
  1639. procedure overflow(@!s:str_number;@!n:integer); {stop due to finiteness}
  1640. begin normalize_selector;
  1641. print_err("METAFONT capacity exceeded, sorry [");
  1642. @.METAFONT capacity exceeded ...@>
  1643. print(s); print_char("="); print_int(n); print_char("]");
  1644. help2("If you really absolutely need more capacity,")@/
  1645.   ("you can ask a wizard to enlarge me.");
  1646. succumb;
  1647. @ The program might sometime run completely amok, at which point there is
  1648. no choice but to stop. If no previous error has been detected, that's bad
  1649. news; a message is printed that is really intended for the \MF\
  1650. maintenance person instead of the user (unless the user has been
  1651. particularly diabolical).  The index entries for `this can't happen' may
  1652. help to pinpoint the problem.
  1653. @^dry rot@>
  1654. @<Error hand...@>=
  1655. procedure confusion(@!s:str_number);
  1656.   {consistency check violated; |s| tells where}
  1657. begin normalize_selector;
  1658. if history<error_message_issued then
  1659.   begin print_err("This can't happen ("); print(s); print_char(")");
  1660. @.This can't happen@>
  1661.   help1("I'm broken. Please show this to someone who can fix can fix");
  1662.   end
  1663. else  begin print_err("I can't go on meeting you like this");
  1664. @.I can't go on...@>
  1665.   help2("One of your faux pas seems to have wounded me deeply...")@/
  1666.     ("in fact, I'm barely conscious. Please fix it and try again.");
  1667.   end;
  1668. succumb;
  1669. @ Users occasionally want to interrupt \MF\ while it's running.
  1670. If the \PASCAL\ runtime system allows this, one can implement
  1671. a routine that sets the global variable |interrupt| to some nonzero value
  1672. when such an interrupt is signalled. Otherwise there is probably at least
  1673. a way to make |interrupt| nonzero using the \PASCAL\ debugger.
  1674. @^system dependencies@>
  1675. @^debugging@>
  1676. @d check_interrupt==begin if interrupt<>0 then pause_for_instructions;
  1677.   end
  1678. @<Global...@>=
  1679. @!interrupt:integer; {should \MF\ pause for instructions?}
  1680. @!OK_to_interrupt:boolean; {should interrupts be observed?}
  1681. @ @<Set init...@>=
  1682. interrupt:=0; OK_to_interrupt:=true;
  1683. @ When an interrupt has been detected, the program goes into its
  1684. highest interaction level and lets the user have the full flexibility of
  1685. the |error| routine.  \MF\ checks for interrupts only at times when it is
  1686. safe to do this.
  1687. @p procedure pause_for_instructions;
  1688. begin if OK_to_interrupt then
  1689.   begin interaction:=error_stop_mode;
  1690.   if (selector=log_only)or(selector=no_print) then
  1691.     incr(selector);
  1692.   print_err("Interruption");
  1693. @.Interruption@>
  1694.   help3("You rang?")@/
  1695.   ("Try to insert some instructions for me (e.g.,`I show x'),")@/
  1696.   ("unless you just want to quit by typing `X'.");
  1697.   deletions_allowed:=false; error; deletions_allowed:=true;
  1698.   interrupt:=0;
  1699.   end;
  1700. @ Many of \MF's error messages state that a missing token has been
  1701. inserted behind the scenes. We can save string space and program space
  1702. by putting this common code into a subroutine.
  1703. @p procedure missing_err(@!s:str_number);
  1704. begin print_err("Missing `"); print(s); print("' has been inserted");
  1705. @.Missing...inserted@>
  1706. @* \[7] Arithmetic with scaled numbers.
  1707. The principal computations performed by \MF\ are done entirely in terms of
  1708. integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this
  1709. program can be carried out in exactly the same way on a wide variety of
  1710. computers, including some small ones.
  1711. @^small computers@>
  1712. But \PASCAL\ does not define the @!|div|
  1713. operation in the case of negative dividends; for example, the result of
  1714. |(-2*n-1) div 2| is |-(n+1)| on some computers and |-n| on others.
  1715. There are two principal types of arithmetic: ``translation-preserving,''
  1716. in which the identity |(a+q*b)div b=(a div b)+q| is valid; and
  1717. ``negation-preserving,'' in which |(-a)div b=-(a div b)|. This leads to
  1718. two \MF s, which can produce different results, although the differences
  1719. should be negligible when the language is being used properly.
  1720. The \TeX\ processor has been defined carefully so that both varieties
  1721. of arithmetic will produce identical output, but it would be too
  1722. inefficient to constrain \MF\ in a similar way.
  1723. @d el_gordo == @'17777777777 {$2^{31}-1$, the largest value that \MF\ likes}
  1724. @ One of \MF's most common operations is the calculation of
  1725. $\lfloor{a+b\over2}\rfloor$,
  1726. the midpoint of two given integers |a| and~|b|. The only decent way to do
  1727. this in \PASCAL\ is to write `|(a+b) div 2|'; but on most machines it is
  1728. far more efficient to calculate `|(a+b)| right shifted one bit'.
  1729. Therefore the midpoint operation will always be denoted by `|half(a+b)|'
  1730. in this program. If \MF\ is being implemented with languages that permit
  1731. binary shifting, the |half| macro should be changed to make this operation
  1732. as efficient as possible.
  1733. @d half(#)==(#) div 2
  1734. @ A single computation might use several subroutine calls, and it is
  1735. desirable to avoid producing multiple error messages in case of arithmetic
  1736. overflow. So the routines below set the global variable |arith_error| to |true|
  1737. instead of reporting errors directly to the user.
  1738. @<Glob...@>=
  1739. @!arith_error:boolean; {has arithmetic overflow occurred recently?}
  1740. @ @<Set init...@>=
  1741. arith_error:=false;
  1742. @ At crucial points the program will say |check_arith|, to test if
  1743. an arithmetic error has been detected.
  1744. @d check_arith==begin if arith_error then clear_arith;@+end
  1745. @p procedure clear_arith;
  1746. begin print_err("Arithmetic overflow");
  1747. @.Arithmetic overflow@>
  1748. help4("Uh, oh. A little while ago one of the quantities that I was")@/
  1749.   ("computing got too large, so I'm afraid your answers will be")@/
  1750.   ("somewhat askew. You'll probably have to adopt different")@/
  1751.   ("tactics next time. But I shall try to carry on anyway.");
  1752. error; arith_error:=false;
  1753. @ Addition is not always checked to make sure that it doesn't overflow,
  1754. but in places where overflow isn't too unlikely the |slow_add| routine
  1755. is used.
  1756. @p function slow_add(@!x,@!y:integer):integer;
  1757. begin if x>=0 then
  1758.   if y<=el_gordo-x then slow_add:=x+y
  1759.   else  begin arith_error:=true; slow_add:=el_gordo;
  1760.     end
  1761. else  if -y<=el_gordo+x then slow_add:=x+y
  1762.   else  begin arith_error:=true; slow_add:=-el_gordo;
  1763.     end;
  1764. @ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples
  1765. of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit
  1766. positions from the right end of a binary computer word.
  1767. @d quarter_unit == @'40000 {$2^{14}$, represents 0.250000}
  1768. @d half_unit == @'100000 {$2^{15}$, represents 0.50000}
  1769. @d three_quarter_unit == @'140000 {$3\cdot2^{14}$, represents 0.75000}
  1770. @d unity == @'200000 {$2^{16}$, represents 1.00000}
  1771. @d two == @'400000 {$2^{17}$, represents 2.00000}
  1772. @d three == @'600000 {$2^{17}+2^{16}$, represents 3.00000}
  1773. @<Types...@>=
  1774. @!scaled = integer; {this type is used for scaled integers}
  1775. @!small_number=0..63; {this type is self-explanatory}
  1776. @ The following function is used to create a scaled integer from a given decimal
  1777. fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is
  1778. given in |dig[i]|, and the calculation produces a correctly rounded result.
  1779. @p function round_decimals(@!k:small_number) : scaled;
  1780.   {converts a decimal fraction}
  1781. var @!a:integer; {the accumulator}
  1782. begin a:=0;
  1783. while k>0 do
  1784.   begin decr(k); a:=(a+dig[k]*two) div 10;
  1785.   end;
  1786. round_decimals:=half(a+1);
  1787. @ Conversely, here is a procedure analogous to |print_int|. If the output
  1788. of this procedure is subsequently read by \MF\ and converted by the
  1789. |round_decimals| routine above, it turns out that the original value will
  1790. be reproduced exactly. A decimal point is printed only if the value is
  1791. not an integer. If there is more than one way to print the result with
  1792. the optimum number of digits following the decimal point, the closest
  1793. possible value is given.
  1794. The invariant relation in the \&{repeat} loop is that a sequence of
  1795. decimal digits yet to be printed will yield the original number if and only if
  1796. they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$.
  1797. We can stop if and only if $f=0$ satisfies this condition; the loop will
  1798. terminate before $s$ can possibly become zero.
  1799. @<Basic printing...@>=
  1800. procedure print_scaled(@!s:scaled); {prints scaled real, rounded to five
  1801.   digits}
  1802. var @!delta:scaled; {amount of allowable inaccuracy}
  1803. begin if s<0 then
  1804.   begin print_char("-"); negate(s); {print the sign, if negative}
  1805.   end;
  1806. print_int(s div unity); {print the integer part}
  1807. s:=10*(s mod unity)+5;
  1808. if s<>5 then
  1809.   begin delta:=10; print_char(".");
  1810.   repeat if delta>unity then
  1811.     s:=s+@'100000-(delta div 2); {round the final digit}
  1812.   print_char("0"+(s div unity)); s:=10*(s mod unity); delta:=delta*10;
  1813.   until s<=delta;
  1814.   end;
  1815. @ We often want to print two scaled quantities in parentheses,
  1816. separated by a comma.
  1817. @<Basic printing...@>=
  1818. procedure print_two(@!x,@!y:scaled); {prints `|(x,y)|'}
  1819. begin print_char("("); print_scaled(x); print_char(","); print_scaled(y);
  1820. print_char(")");
  1821. @ The |scaled| quantities in \MF\ programs are generally supposed to be
  1822. less than $2^{12}$ in absolute value, so \MF\ does much of its internal
  1823. arithmetic with 28~significant bits of precision. A |fraction| denotes
  1824. a scaled integer whose binary point is assumed to be 28 bit positions
  1825. from the right.
  1826. @d fraction_half==@'1000000000 {$2^{27}$, represents 0.50000000}
  1827. @d fraction_one==@'2000000000 {$2^{28}$, represents 1.00000000}
  1828. @d fraction_two==@'4000000000 {$2^{29}$, represents 2.00000000}
  1829. @d fraction_three==@'6000000000 {$3\cdot2^{28}$, represents 3.00000000}
  1830. @d fraction_four==@'10000000000 {$2^{30}$, represents 4.00000000}
  1831. @<Types...@>=
  1832. @!fraction=integer; {this type is used for scaled fractions}
  1833. @ In fact, the two sorts of scaling discussed above aren't quite
  1834. sufficient; \MF\ has yet another, used internally to keep track of angles
  1835. in units of $2^{-20}$ degrees.
  1836. @d forty_five_deg==@'264000000 {$45\cdot2^{20}$, represents $45^\circ$}
  1837. @d ninety_deg==@'550000000 {$90\cdot2^{20}$, represents $90^\circ$}
  1838. @d one_eighty_deg==@'1320000000 {$180\cdot2^{20}$, represents $180^\circ$}
  1839. @d three_sixty_deg==@'2640000000 {$360\cdot2^{20}$, represents $360^\circ$}
  1840. @<Types...@>=
  1841. @!angle=integer; {this type is used for scaled angles}
  1842. @ The |make_fraction| routine produces the |fraction| equivalent of
  1843. |p/q|, given integers |p| and~|q|; it computes the integer
  1844. $f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are
  1845. positive. If |p| and |q| are both of the same scaled type |t|,
  1846. the ``type relation'' |make_fraction(t,t)=fraction| is valid;
  1847. and it's also possible to use the subroutine ``backwards,'' using
  1848. the relation |make_fraction(t,fraction)=t| between scaled types.
  1849. If the result would have magnitude $2^{31}$ or more, |make_fraction|
  1850. sets |arith_error:=true|. Most of \MF's internal computations have
  1851. been designed to avoid this sort of error.
  1852. If this subroutine were programmed in assembly language on a typical
  1853. machine, we could simply compute |(@t$2^{28}$@>*p)div q|, since a
  1854. double-precision product can often be input to a fixed-point division
  1855. instruction. But when we are restricted to \PASCAL\ arithmetic it
  1856. is necessary either to resort to multiple-precision maneuvering
  1857. or to use a simple but slow iteration. The multiple-precision technique
  1858. would be about three times faster than the code adopted here, but it
  1859. would be comparatively long and tricky, involving about sixteen
  1860. additional multiplications and divisions.
  1861. This operation is part of \MF's ``inner loop''; indeed, it will
  1862. consume nearly 10\pct! of the running time (exclusive of input and output)
  1863. if the code below is left unchanged. A machine-dependent recoding
  1864. will therefore make \MF\ run faster. The present implementation
  1865. is highly portable, but slow; it avoids multiplication and division
  1866. except in the initial stage. System wizards should be careful to
  1867. replace it with a routine that is guaranteed to produce identical
  1868. results in all cases.
  1869. @^system dependencies@>
  1870. As noted below, a few more routines should also be replaced by machine-dependent
  1871. code, for efficiency. But when a procedure is not part of the ``inner loop,''
  1872. such changes aren't advisable; simplicity and robustness are
  1873. preferable to trickery, unless the cost is too high.
  1874. @^inner loop@>
  1875. @p function make_fraction(@!p,@!q:integer):fraction;
  1876. var @!f:integer; {the fraction bits, with a leading 1 bit}
  1877. @!n:integer; {the integer part of $\vert p/q\vert$}
  1878. @!negative:boolean; {should the result be negated?}
  1879. @!be_careful:integer; {disables certain compiler optimizations}
  1880. begin if p>=0 then negative:=false
  1881. else  begin negate(p); negative:=true;
  1882.   end;
  1883. if q<=0 then
  1884.   begin debug if q=0 then confusion("/");@;@+gubed@;@/
  1885. @:this can't happen /}{\quad \./@>
  1886.   negate(q); negative:=not negative;
  1887.   end;
  1888. n:=p div q; p:=p mod q;
  1889. if n>=8 then
  1890.   begin arith_error:=true;
  1891.   if negative then make_fraction:=-el_gordo@+else make_fraction:=el_gordo;
  1892.   end
  1893. else  begin n:=(n-1)*fraction_one;
  1894.   @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>;
  1895.   if negative then make_fraction:=-(f+n)@+else make_fraction:=f+n;
  1896.   end;
  1897. @ The |repeat| loop here preserves the following invariant relations
  1898. between |f|, |p|, and~|q|:
  1899. (i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and
  1900. $p_0$ is the original value of~$p$.
  1901. Notice that the computation specifies
  1902. |(p-q)+p| instead of |(p+p)-q|, because the latter could overflow.
  1903. Let us hope that optimizing compilers do not miss this point; a
  1904. special variable |be_careful| is used to emphasize the necessary
  1905. order of computation. Optimizing compilers should keep |be_careful|
  1906. in a register, not store it in memory.
  1907. @^inner loop@>
  1908. @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>=
  1909. f:=1;
  1910. repeat be_careful:=p-q; p:=be_careful+p;
  1911. if p>=0 then f:=f+f+1
  1912. else  begin double(f); p:=p+q;
  1913.   end;
  1914. until f>=fraction_one;
  1915. be_careful:=p-q;
  1916. if be_careful+p>=0 then incr(f)
  1917. @ The dual of |make_fraction| is |take_fraction|, which multiplies a
  1918. given integer~|q| by a fraction~|f|. When the operands are positive, it
  1919. computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function
  1920. of |q| and~|f|.
  1921. This routine is even more ``inner loopy'' than |make_fraction|;
  1922. the present implementation consumes almost 20\pct! of \MF's computation
  1923. time during typical jobs, so a machine-language substitute is advisable.
  1924. @^inner loop@> @^system dependencies@>
  1925. @p function take_fraction(@!q:integer;@!f:fraction):integer;
  1926. var @!p:integer; {the fraction so far}
  1927. @!negative:boolean; {should the result be negated?}
  1928. @!n:integer; {additional multiple of $q$}
  1929. @!be_careful:integer; {disables certain compiler optimizations}
  1930. begin @<Reduce to the case that |f>=0| and |q>0|@>;
  1931. if f<fraction_one then n:=0
  1932. else  begin n:=f div fraction_one; f:=f mod fraction_one;
  1933.   if q<=el_gordo div n then n:=n*q
  1934.   else  begin arith_error:=true; n:=el_gordo;
  1935.     end;
  1936.   end;
  1937. f:=f+fraction_one;
  1938. @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>;
  1939. be_careful:=n-el_gordo;
  1940. if be_careful+p>0 then
  1941.   begin arith_error:=true; n:=el_gordo-p;
  1942.   end;
  1943. if negative then take_fraction:=-(n+p)
  1944. else take_fraction:=n+p;
  1945. @ @<Reduce to the case that |f>=0| and |q>0|@>=
  1946. if f>=0 then negative:=false
  1947. else  begin negate(f); negative:=true;
  1948.   end;
  1949. if q<0 then
  1950.   begin negate(q); negative:=not negative;
  1951.   end;
  1952. @ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor
  1953. =\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and
  1954. $f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$.
  1955. @^inner loop@>
  1956. @<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>=
  1957. p:=fraction_half; {that's $2^{27}$; the invariants hold now with $k=28$}
  1958. if q<fraction_four then
  1959.   repeat if odd(f) then p:=half(p+q)@+else p:=half(p);
  1960.   f:=half(f);
  1961.   until f=1
  1962. else  repeat if odd(f) then p:=p+half(q-p)@+else p:=half(p);
  1963.   f:=half(f);
  1964.   until f=1
  1965. @ When we want to multiply something by a |scaled| quantity, we use a scheme
  1966. analogous to |take_fraction| but with a different scaling.
  1967. Given positive operands, |take_scaled|
  1968. computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$.
  1969. Once again it is a good idea to use a machine-language replacement if
  1970. possible; otherwise |take_scaled| will use more than 2\pct! of the running time
  1971. when the Computer Modern fonts are being generated.
  1972. @^inner loop@>
  1973. @p function take_scaled(@!q:integer;@!f:scaled):integer;
  1974. var @!p:integer; {the fraction so far}
  1975. @!negative:boolean; {should the result be negated?}
  1976. @!n:integer; {additional multiple of $q$}
  1977. @!be_careful:integer; {disables certain compiler optimizations}
  1978. begin @<Reduce to the case that |f>=0| and |q>0|@>;
  1979. if f<unity then n:=0
  1980. else  begin n:=f div unity; f:=f mod unity;
  1981.   if q<=el_gordo div n then n:=n*q
  1982.   else  begin arith_error:=true; n:=el_gordo;
  1983.     end;
  1984.   end;
  1985. f:=f+unity;
  1986. @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>;
  1987. be_careful:=n-el_gordo;
  1988. if be_careful+p>0 then
  1989.   begin arith_error:=true; n:=el_gordo-p;
  1990.   end;
  1991. if negative then take_scaled:=-(n+p)
  1992. else take_scaled:=n+p;
  1993. @ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>=
  1994. p:=half_unit; {that's $2^{15}$; the invariants hold now with $k=16$}
  1995. @^inner loop@>
  1996. if q<fraction_four then
  1997.   repeat if odd(f) then p:=half(p+q)@+else p:=half(p);
  1998.   f:=half(f);
  1999.   until f=1
  2000. else  repeat if odd(f) then p:=p+half(q-p)@+else p:=half(p);
  2001.   f:=half(f);
  2002.   until f=1
  2003. @ For completeness, there's also |make_scaled|, which computes a
  2004. quotient as a |scaled| number instead of as a |fraction|.
  2005. In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the
  2006. operands are positive. \ (This procedure is not used especially often,
  2007. so it is not part of \MF's inner loop.)
  2008. @p function make_scaled(@!p,@!q:integer):scaled;
  2009. var @!f:integer; {the fraction bits, with a leading 1 bit}
  2010. @!n:integer; {the integer part of $\vert p/q\vert$}
  2011. @!negative:boolean; {should the result be negated?}
  2012. @!be_careful:integer; {disables certain compiler optimizations}
  2013. begin if p>=0 then negative:=false
  2014. else  begin negate(p); negative:=true;
  2015.   end;
  2016. if q<=0 then
  2017.   begin debug if q=0 then confusion("/");@+gubed@;@/
  2018. @:this can't happen /}{\quad \./@>
  2019.   negate(q); negative:=not negative;
  2020.   end;
  2021. n:=p div q; p:=p mod q;
  2022. if n>=@'100000 then
  2023.   begin arith_error:=true;
  2024.   if negative then make_scaled:=-el_gordo@+else make_scaled:=el_gordo;
  2025.   end
  2026. else  begin n:=(n-1)*unity;
  2027.   @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>;
  2028.   if negative then make_scaled:=-(f+n)@+else make_scaled:=f+n;
  2029.   end;
  2030. @ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>=
  2031. f:=1;
  2032. repeat be_careful:=p-q; p:=be_careful+p;
  2033. if p>=0 then f:=f+f+1
  2034. else  begin double(f); p:=p+q;
  2035.   end;
  2036. until f>=unity;
  2037. be_careful:=p-q;
  2038. if be_careful+p>=0 then incr(f)
  2039. @ Here is a typical example of how the routines above can be used.
  2040. It computes the function
  2041. $${1\over3\tau}f(\theta,\phi)=
  2042. {\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi)
  2043.  (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over
  2044. 3\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$
  2045. where $\tau$ is a |scaled| ``tension'' parameter. This is \MF's magic
  2046. fudge factor for placing the first control point of a curve that starts
  2047. at an angle $\theta$ and ends at an angle $\phi$ from the straight path.
  2048. (Actually, if the stated quantity exceeds 4, \MF\ reduces it to~4.)
  2049. The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$.
  2050. (It's a sum of eight terms whose absolute values can be bounded using
  2051. relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator
  2052. is positive; and since the tension $\tau$ is constrained to be at least
  2053. $3\over4$, the numerator is less than $16\over3$. The denominator is
  2054. nonnegative and at most~6.  Hence the fixed-point calculations below
  2055. are guaranteed to stay within the bounds of a 32-bit computer word.
  2056. The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction|
  2057. arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$,
  2058. $\sin\phi$, and $\cos\phi$, respectively.
  2059. @p function velocity(@!st,@!ct,@!sf,@!cf:fraction;@!t:scaled):fraction;
  2060. var @!acc,@!num,@!denom:integer; {registers for intermediate calculations}
  2061. begin acc:=take_fraction(st-(sf div 16), sf-(st div 16));
  2062. acc:=take_fraction(acc,ct-cf);
  2063. num:=fraction_two+take_fraction(acc,379625062);
  2064.   {$2^{28}\sqrt2\approx379625062.497$}
  2065. denom:=fraction_three+take_fraction(ct,497706707)+take_fraction(cf,307599661);
  2066.   {$3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and
  2067.     $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$}
  2068. if t<>unity then num:=make_scaled(num,t);
  2069.   {|make_scaled(fraction,scaled)=fraction|}
  2070. if num div 4>=denom then velocity:=fraction_four
  2071. else velocity:=make_fraction(num,denom);
  2072. @ The following somewhat different subroutine tests rigorously if $ab$ is
  2073. greater than, equal to, or less than~$cd$,
  2074. given integers $(a,b,c,d)$. In most cases a quick decision is reached.
  2075. The result is $+1$, 0, or~$-1$ in the three respective cases.
  2076. @d return_sign(#)==begin ab_vs_cd:=#; return;
  2077.   end
  2078. @p function ab_vs_cd(@!a,b,c,d:integer):integer;
  2079. label exit;
  2080. var @!q,@!r:integer; {temporary registers}
  2081. begin @<Reduce to the case that |a,c>=0|, |b,d>0|@>;
  2082. loop@+  begin q := a div d; r := c div b;
  2083.   if q<>r then
  2084.     if q>r then return_sign(1)@+else return_sign(-1);
  2085.   q := a mod d; r := c mod b;
  2086.   if r=0 then
  2087.     if q=0 then return_sign(0)@+else return_sign(1);
  2088.   if q=0 then return_sign(-1);
  2089.   a:=b; b:=q; c:=d; d:=r;
  2090.   end; {now |a>d>0| and |c>b>0|}
  2091. exit:end;
  2092. @ @<Reduce to the case that |a...@>=
  2093. if a<0 then
  2094.   begin negate(a); negate(b);
  2095.   end;
  2096. if c<0 then
  2097.   begin negate(c); negate(d);
  2098.   end;
  2099. if d<=0 then
  2100.   begin if b>=0 then
  2101.     if ((a=0)or(b=0))and((c=0)or(d=0)) then return_sign(0)
  2102.     else return_sign(1);
  2103.   if d=0 then
  2104.     if a=0 then return_sign(0)@+else return_sign(-1);
  2105.   q:=a; a:=c; c:=q; q:=-b; b:=-d; d:=q;
  2106.   end
  2107. else if b<=0 then
  2108.   begin if b<0 then if a>0 then return_sign(-1);
  2109.   if c=0 then return_sign(0) else return_sign(-1);
  2110.   end
  2111. @ We conclude this set of elementary routines with some simple rounding
  2112. and truncation operations that are coded in a machine-independent fashion.
  2113. The routines are slightly complicated because we want them to work
  2114. without overflow whenever $-2^{31}\L x<2^{31}$.
  2115. @p function floor_scaled(@!x:scaled):scaled;
  2116.   {$2^{16}\lfloor x/2^{16}\rfloor$}
  2117. var @!be_careful:integer; {temporary register}
  2118. begin if x>=0 then floor_scaled:=x-(x mod unity)
  2119. else  begin be_careful:=x+1;
  2120.   floor_scaled:=x+((-be_careful) mod unity)+1-unity;
  2121.   end;
  2122. function floor_unscaled(@!x:scaled):integer;
  2123.   {$\lfloor x/2^{16}\rfloor$}
  2124. var @!be_careful:integer; {temporary register}
  2125. begin if x>=0 then floor_unscaled:=x div unity
  2126. else  begin be_careful:=x+1; floor_unscaled:=-(1+((-be_careful) div unity));
  2127.   end;
  2128. function round_unscaled(@!x:scaled):integer;
  2129.   {$\lfloor x/2^{16}+.5\rfloor$}
  2130. var @!be_careful:integer; {temporary register}
  2131. begin if x>=half_unit then round_unscaled:=1+((x-half_unit) div unity)
  2132. else if x>=-half_unit then round_unscaled:=0
  2133. else  begin be_careful:=x+1;
  2134.   round_unscaled:=-(1+((-be_careful-half_unit) div unity));
  2135.   end;
  2136. function round_fraction(@!x:fraction):scaled;
  2137.   {$\lfloor x/2^{12}+.5\rfloor$}
  2138. var @!be_careful:integer; {temporary register}
  2139. begin if x>=2048 then round_fraction:=1+((x-2048) div 4096)
  2140. else if x>=-2048 then round_fraction:=0
  2141. else  begin be_careful:=x+1;
  2142.   round_fraction:=-(1+((-be_careful-2048) div 4096));
  2143.   end;
  2144. @* \[8] Algebraic and transcendental functions.
  2145. \MF\ computes all of the necessary special functions from scratch, without
  2146. relying on |real| arithmetic or system subroutines for sines, cosines, etc.
  2147. @ To get the square root of a |scaled| number |x|, we want to calculate
  2148. $s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique
  2149. integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine
  2150. determines $s$ by an iterative method that maintains the invariant
  2151. relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor
  2152. -s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$
  2153. might, however, be zero at the start of the first iteration.
  2154. @p function square_rt(@!x:scaled):scaled;
  2155. var @!k:small_number; {iteration control counter}
  2156. @!y,@!q:integer; {registers for intermediate calculations}
  2157. begin if x<=0 then @<Handle square root of zero or negative argument@>
  2158. else  begin k:=23; q:=2;
  2159.   while x<fraction_two do {i.e., |while x<@t$2^{29}$@>|\unskip}
  2160.     begin decr(k); x:=x+x+x+x;
  2161.     end;
  2162.   if x<fraction_four then y:=0
  2163.   else  begin x:=x-fraction_four; y:=1;
  2164.     end;
  2165.   repeat @<Decrease |k| by 1, maintaining the invariant
  2166.     relations between |x|, |y|, and~|q|@>;
  2167.   until k=0;
  2168.   square_rt:=half(q);
  2169.   end;
  2170. @ @<Handle square root of zero...@>=
  2171. begin if x<0 then
  2172.   begin print_err("Square root of ");
  2173. @.Square root...replaced by 0@>
  2174.   print_scaled(x); print(" has been replaced by 0");
  2175.   help2("Since I don't take square roots of negative numbers,")@/
  2176.     ("I'm zeroing this one. Proceed, with fingers crossed.");
  2177.   error;
  2178.   end;
  2179. square_rt:=0;
  2180. @ @<Decrease |k| by 1, maintaining...@>=
  2181. double(x); double(y);
  2182. if x>=fraction_four then {note that |fraction_four=@t$2^{30}$@>|}
  2183.   begin x:=x-fraction_four; incr(y);
  2184.   end;
  2185. double(x); y:=y+y-q; double(q);
  2186. if x>=fraction_four then
  2187.   begin x:=x-fraction_four; incr(y);
  2188.   end;
  2189. if y>q then
  2190.   begin y:=y-q; q:=q+2;
  2191.   end
  2192. else if y<=0 then
  2193.   begin q:=q-2; y:=y+q;
  2194.   end;
  2195. decr(k)
  2196. @ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant
  2197. iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal
  2198. @^Moler, Cleve Barry@>
  2199. @^Morrison, Donald Ross@>
  2200. of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b|
  2201. in such a way that their Pythagorean sum remains invariant, while the
  2202. smaller argument decreases.
  2203. @p function pyth_add(@!a,@!b:integer):integer;
  2204. label done;
  2205. var @!r:fraction; {register used to transform |a| and |b|}
  2206. @!big:boolean; {is the result dangerously near $2^{31}$?}
  2207. begin a:=abs(a); b:=abs(b);
  2208. if a<b then
  2209.   begin r:=b; b:=a; a:=r;
  2210.   end; {now |0<=b<=a|}
  2211. if a>0 then
  2212.   begin if a<fraction_two then big:=false
  2213.   else  begin a:=a div 4; b:=b div 4; big:=true;
  2214.     end; {we reduced the precision to avoid arithmetic overflow}
  2215.   @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>;
  2216.   if big then
  2217.     if a<fraction_two then a:=a+a+a+a
  2218.     else  begin arith_error:=true; a:=el_gordo;
  2219.       end;
  2220.   end;
  2221. pyth_add:=a;
  2222. @ The key idea here is to reflect the vector $(a,b)$ about the
  2223. line through $(a,b/2)$.
  2224. @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>=
  2225. loop@+  begin r:=make_fraction(b,a);
  2226.   r:=take_fraction(r,r); {now $r\approx b^2/a^2$}
  2227.   if r=0 then goto done;
  2228.   r:=make_fraction(r,fraction_four+r);
  2229.   a:=a+take_fraction(a+a,r); b:=take_fraction(b,r);
  2230.   end;
  2231. done:
  2232. @ Here is a similar algorithm for $\psqrt{a^2-b^2}$.
  2233. It converges slowly when $b$ is near $a$, but otherwise it works fine.
  2234. @p function pyth_sub(@!a,@!b:integer):integer;
  2235. label done;
  2236. var @!r:fraction; {register used to transform |a| and |b|}
  2237. @!big:boolean; {is the input dangerously near $2^{31}$?}
  2238. begin a:=abs(a); b:=abs(b);
  2239. if a<=b then @<Handle erroneous |pyth_sub| and set |a:=0|@>
  2240. else  begin if a<fraction_four then big:=false
  2241.   else  begin a:=half(a); b:=half(b); big:=true;
  2242.     end;
  2243.   @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>;
  2244.   if big then a:=a+a;
  2245.   end;
  2246. pyth_sub:=a;
  2247. @ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>=
  2248. loop@+  begin r:=make_fraction(b,a);
  2249.   r:=take_fraction(r,r); {now $r\approx b^2/a^2$}
  2250.   if r=0 then goto done;
  2251.   r:=make_fraction(r,fraction_four-r);
  2252.   a:=a-take_fraction(a+a,r); b:=take_fraction(b,r);
  2253.   end;
  2254. done:
  2255. @ @<Handle erroneous |pyth_sub| and set |a:=0|@>=
  2256. begin if a<b then
  2257.   begin print_err("Pythagorean subtraction "); print_scaled(a);
  2258.   print("+-+"); print_scaled(b); print(" has been replaced by 0");
  2259. @.Pythagorean...@>
  2260.   help2("Since I don't take square roots of negative numbers,")@/
  2261.     ("I'm zeroing this one. Proceed, with fingers crossed.");
  2262.   error;
  2263.   end;
  2264. a:=0;
  2265. @ The subroutines for logarithm and exponential involve two tables.
  2266. The first is simple: |two_to_the[k]| equals $2^k$. The second involves
  2267. a bit more calculation, which the author claims to have done correctly:
  2268. |spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)=
  2269. 2^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the
  2270. nearest integer.
  2271. @<Glob...@>=
  2272. @!two_to_the:array[0..30] of integer; {powers of two}
  2273. @!spec_log:array[1..28] of integer; {special logarithms}
  2274. @ @<Local variables for initialization@>=
  2275. @!k:integer; {all-purpose loop index}
  2276. @ @<Set init...@>=
  2277. two_to_the[0]:=1;
  2278. for k:=1 to 30 do two_to_the[k]:=2*two_to_the[k-1];
  2279. spec_log[1]:=93032640;
  2280. spec_log[2]:=38612034;
  2281. spec_log[3]:=17922280;
  2282. spec_log[4]:=8662214;
  2283. spec_log[5]:=4261238;
  2284. spec_log[6]:=2113709;
  2285. spec_log[7]:=1052693;
  2286. spec_log[8]:=525315;
  2287. spec_log[9]:=262400;
  2288. spec_log[10]:=131136;
  2289. spec_log[11]:=65552;
  2290. spec_log[12]:=32772;
  2291. spec_log[13]:=16385;
  2292. for k:=14 to 27 do spec_log[k]:=two_to_the[27-k];
  2293. spec_log[28]:=1;
  2294. @ Here is the routine that calculates $2^8$ times the natural logarithm
  2295. of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$,
  2296. when |x| is a given positive integer.
  2297. The method is based on exercise 1.2.2--25 in {\sl The Art of Computer
  2298. Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$,
  2299. and the logarithm of $2^{30}x$ remains to be added to an accumulator
  2300. register called~$y$. Three auxiliary bits of accuracy are retained in~$y$
  2301. during the calculation, and sixteen auxiliary bits to extend |y| are
  2302. kept in~|z| during the initial argument reduction. (We add
  2303. $100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will
  2304. not become negative; also, the actual amount subtracted from~|y| is~96,
  2305. not~100, because we want to add~4 for rounding before the final division by~8.)
  2306. @p function m_log(@!x:scaled):scaled;
  2307. var @!y,@!z:integer; {auxiliary registers}
  2308. @!k:integer; {iteration counter}
  2309. begin if x<=0 then @<Handle non-positive logarithm@>
  2310. else  begin y:=1302456956+4-100; {$14\times2^{27}\ln2\approx1302456956.421063$}
  2311.   z:=27595+6553600; {and $2^{16}\times .421063\approx 27595$}
  2312.   while x<fraction_four do
  2313.     begin double(x); y:=y-93032639; z:=z-48782;
  2314.     end; {$2^{27}\ln2\approx 93032639.74436163$
  2315.       and $2^{16}\times.74436163\approx 48782$}
  2316.   y:=y+(z div unity); k:=2;
  2317.   while x>fraction_four+4 do
  2318.     @<Increase |k| until |x| can be multiplied by a
  2319.       factor of $2^{-k}$, and adjust $y$ accordingly@>;
  2320.   m_log:=y div 8;
  2321.   end;
  2322. @ @<Increase |k| until |x| can...@>=
  2323. begin z:=((x-1) div two_to_the[k])+1; {$z=\lceil x/2^k\rceil$}
  2324. while x<fraction_four+z do
  2325.   begin z:=half(z+1); k:=k+1;
  2326.   end;
  2327. y:=y+spec_log[k]; x:=x-z;
  2328. @ @<Handle non-positive logarithm@>=
  2329. begin print_err("Logarithm of ");
  2330. @.Logarithm...replaced by 0@>
  2331. print_scaled(x); print(" has been replaced by 0");
  2332. help2("Since I don't take logs of non-positive numbers,")@/
  2333.   ("I'm zeroing this one. Proceed, with fingers crossed.");
  2334. error; m_log:=0;
  2335. @ Conversely, the exponential routine calculates $\exp(x/2^8)$,
  2336. when |x| is |scaled|. The result is an integer approximation to
  2337. $2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer.
  2338. @p function m_exp(@!x:scaled):scaled;
  2339. var @!k:small_number; {loop control index}
  2340. @!y,@!z:integer; {auxiliary registers}
  2341. begin if x>174436200 then
  2342.     {$2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$}
  2343.   begin arith_error:=true; m_exp:=el_gordo;
  2344.   end
  2345. else if x<-197694359 then m_exp:=0
  2346.     {$2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$}
  2347. else  begin if x<=0 then
  2348.     begin z:=-8*x; y:=@'4000000; {$y=2^{20}$}
  2349.     end
  2350.   else  begin if x<=127919879 then z:=1023359037-8*x
  2351.       {$2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$}
  2352.     else z:=8*(174436200-x); {|z| is always nonnegative}
  2353.     y:=el_gordo;
  2354.     end;
  2355.   @<Multiply |y| by $\exp(-z/2^{27})$@>;
  2356.   if x<=127919879 then m_exp:=(y+8) div 16@+else m_exp:=y;
  2357.   end;
  2358. @ The idea here is that subtracting |spec_log[k]| from |z| corresponds
  2359. to multiplying |y| by $1-2^{-k}$.
  2360. A subtle point (which had to be checked) was that if $x=127919879$, the
  2361. value of~|y| will decrease so that |y+8| doesn't overflow. In fact,
  2362. $z$ will be 5 in this case, and |y| will decrease by~64 when |k=25|
  2363. and by~16 when |k=27|.
  2364. @<Multiply |y| by...@>=
  2365. k:=1;
  2366. while z>0 do
  2367.   begin while z>=spec_log[k] do
  2368.     begin z:=z-spec_log[k];
  2369.     y:=y-1-((y-two_to_the[k-1]) div two_to_the[k]);
  2370.     end;
  2371.   incr(k);
  2372.   end
  2373. @ The trigonometric subroutines use an auxiliary table such that
  2374. |spec_atan[k]| contains an approximation to the |angle| whose tangent
  2375. is~$1/2^k$.
  2376. @<Glob...@>=
  2377. @!spec_atan:array[1..26] of angle; {$\arctan2^{-k}$ times $2^{20}\cdot180/\pi$}
  2378. @ @<Set init...@>=
  2379. spec_atan[1]:=27855475;
  2380. spec_atan[2]:=14718068;
  2381. spec_atan[3]:=7471121;
  2382. spec_atan[4]:=3750058;
  2383. spec_atan[5]:=1876857;
  2384. spec_atan[6]:=938658;
  2385. spec_atan[7]:=469357;
  2386. spec_atan[8]:=234682;
  2387. spec_atan[9]:=117342;
  2388. spec_atan[10]:=58671;
  2389. spec_atan[11]:=29335;
  2390. spec_atan[12]:=14668;
  2391. spec_atan[13]:=7334;
  2392. spec_atan[14]:=3667;
  2393. spec_atan[15]:=1833;
  2394. spec_atan[16]:=917;
  2395. spec_atan[17]:=458;
  2396. spec_atan[18]:=229;
  2397. spec_atan[19]:=115;
  2398. spec_atan[20]:=57;
  2399. spec_atan[21]:=29;
  2400. spec_atan[22]:=14;
  2401. spec_atan[23]:=7;
  2402. spec_atan[24]:=4;
  2403. spec_atan[25]:=2;
  2404. spec_atan[26]:=1;
  2405. @ Given integers |x| and |y|, not both zero, the |n_arg| function
  2406. returns the |angle| whose tangent points in the direction $(x,y)$.
  2407. This subroutine first determines the correct octant, then solves the
  2408. problem for |0<=y<=x|, then converts the result appropriately to
  2409. return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|.
  2410. (The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of
  2411. |-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.)
  2412. The octants are represented in a ``Gray code,'' since that turns out
  2413. to be computationally simplest.
  2414. @d negate_x=1
  2415. @d negate_y=2
  2416. @d switch_x_and_y=4
  2417. @d first_octant=1
  2418. @d second_octant=first_octant+switch_x_and_y
  2419. @d third_octant=first_octant+switch_x_and_y+negate_x
  2420. @d fourth_octant=first_octant+negate_x
  2421. @d fifth_octant=first_octant+negate_x+negate_y
  2422. @d sixth_octant=first_octant+switch_x_and_y+negate_x+negate_y
  2423. @d seventh_octant=first_octant+switch_x_and_y+negate_y
  2424. @d eighth_octant=first_octant+negate_y
  2425. @p function n_arg(@!x,@!y:integer):angle;
  2426. var @!z:angle; {auxiliary register}
  2427. @!t:integer; {temporary storage}
  2428. @!k:small_number; {loop counter}
  2429. @!octant:first_octant..sixth_octant; {octant code}
  2430. begin if x>=0 then octant:=first_octant
  2431. else  begin negate(x); octant:=first_octant+negate_x;
  2432.   end;
  2433. if y<0 then
  2434.   begin negate(y); octant:=octant+negate_y;
  2435.   end;
  2436. if x<y then
  2437.   begin t:=y; y:=x; x:=t; octant:=octant+switch_x_and_y;
  2438.   end;
  2439. if x=0 then @<Handle undefined arg@>
  2440. else  begin @<Set variable |z| to the arg of $(x,y)$@>;
  2441.   @<Return an appropriate answer based on |z| and |octant|@>;
  2442.   end;
  2443. @ @<Handle undefined arg@>=
  2444. begin print_err("angle(0,0) is taken as zero");
  2445. @.angle(0,0)...zero@>
  2446. help2("The `angle' between two identical points is undefined.")@/
  2447.   ("I'm zeroing this one. Proceed, with fingers crossed.");
  2448. error; n_arg:=0;
  2449. @ @<Return an appropriate answer...@>=
  2450. case octant of
  2451. first_octant:n_arg:=z;
  2452. second_octant:n_arg:=ninety_deg-z;
  2453. third_octant:n_arg:=ninety_deg+z;
  2454. fourth_octant:n_arg:=one_eighty_deg-z;
  2455. fifth_octant:n_arg:=z-one_eighty_deg;
  2456. sixth_octant:n_arg:=-z-ninety_deg;
  2457. seventh_octant:n_arg:=z-ninety_deg;
  2458. eighth_octant:n_arg:=-z;
  2459. end {there are no other cases}
  2460. @ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up
  2461. or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations
  2462. will be made.
  2463. @<Set variable |z| to the arg...@>=
  2464. while x>=fraction_two do
  2465.   begin x:=half(x); y:=half(y);
  2466.   end;
  2467. z:=0;
  2468. if y>0 then
  2469.   begin while x<fraction_one do
  2470.     begin double(x); double(y);
  2471.     end;
  2472.   @<Increase |z| to the arg of $(x,y)$@>;
  2473.   end
  2474. @ During the calculations of this section, variables |x| and~|y|
  2475. represent actual coordinates $(x,2^{-k}y)$. We will maintain the
  2476. condition |x>=y|, so that the tangent will be at most $2^{-k}$.
  2477. If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation
  2478. $(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by
  2479. coordinates whose angle has decreased by~$\phi$; in the special case
  2480. $a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces
  2481. to the particularly simple iteration shown here. [Cf.~John E. Meggitt,
  2482. @^Meggitt, John E.@>
  2483. {\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.]
  2484. The initial value of |x| will be multiplied by at most
  2485. $(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence
  2486. there is no chance of integer overflow.
  2487. @<Increase |z|...@>=
  2488. k:=0;
  2489. repeat double(y); incr(k);
  2490. if y>x then
  2491.   begin z:=z+spec_atan[k]; t:=x; x:=x+(y div two_to_the[k+k]); y:=y-t;
  2492.   end;
  2493. until k=15;
  2494. repeat double(y); incr(k);
  2495. if y>x then
  2496.   begin z:=z+spec_atan[k]; y:=y-x;
  2497.   end;
  2498. until k=26
  2499. @ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine
  2500. and cosine of that angle. The results of this routine are
  2501. stored in global integer variables |n_sin| and |n_cos|.
  2502. @<Glob...@>=
  2503. @!n_sin,@!n_cos:fraction; {results computed by |n_sin_cos|}
  2504. @ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees,
  2505. the purpose of |n_sin_cos(z)| is to set
  2506. |x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately),
  2507. for some rather large number~|r|. The maximum of |x| and |y|
  2508. will be between $2^{28}$ and $2^{30}$, so that there will be hardly
  2509. any loss of accuracy. Then |x| and~|y| are divided by~|r|.
  2510. @p procedure n_sin_cos(@!z:angle); {computes a multiple of the sine and cosine}
  2511. var @!k:small_number; {loop control variable}
  2512. @!q:0..7; {specifies the quadrant}
  2513. @!r:fraction; {magnitude of |(x,y)|}
  2514. @!x,@!y,@!t:integer; {temporary registers}
  2515. begin while z<0 do z:=z+three_sixty_deg;
  2516. z:=z mod three_sixty_deg; {now |0<=z<three_sixty_deg|}
  2517. q:=z div forty_five_deg; z:=z mod forty_five_deg;
  2518. x:=fraction_one; y:=x;
  2519. if not odd(q) then z:=forty_five_deg-z;
  2520. @<Subtract angle |z| from |(x,y)|@>;
  2521. @<Convert |(x,y)| to the octant determined by~|q|@>;
  2522. r:=pyth_add(x,y); n_cos:=make_fraction(x,r); n_sin:=make_fraction(y,r);
  2523. @ In this case the octants are numbered sequentially.
  2524. @<Convert |(x,...@>=
  2525. case q of
  2526. 0:do_nothing;
  2527. 1:begin t:=x; x:=y; y:=t;
  2528.   end;
  2529. 2:begin t:=x; x:=-y; y:=t;
  2530.   end;
  2531. 3:negate(x);
  2532. 4:begin negate(x); negate(y);
  2533.   end;
  2534. 5:begin t:=x; x:=-y; y:=-t;
  2535.   end;
  2536. 6:begin t:=x; x:=y; y:=-t;
  2537.   end;
  2538. 7:negate(y);
  2539. end {there are no other cases}
  2540. @ The main iteration of |n_sin_cos| is similar to that of |n_arg| but
  2541. applied in reverse. The values of |spec_atan[k]| decrease slowly enough
  2542. that this loop is guaranteed to terminate before the (nonexistent) value
  2543. |spec_atan[27]| would be required.
  2544. @<Subtract angle |z|...@>=
  2545. k:=1;
  2546. while z>0 do
  2547.   begin if z>=spec_atan[k] then
  2548.     begin z:=z-spec_atan[k]; t:=x;@/
  2549.     x:=t+y div two_to_the[k];
  2550.     y:=y-t div two_to_the[k];
  2551.     end;
  2552.   incr(k);
  2553.   end;
  2554. if y<0 then y:=0 {this precaution may never be needed}
  2555. @ And now let's complete our collection of numeric utility routines
  2556. by considering random number generation.
  2557. \MF\ generates pseudo-random numbers with the additive scheme recommended
  2558. in Section 3.6 of {\sl The Art of Computer Programming}; however, the
  2559. results are random fractions between 0 and |fraction_one-1|, inclusive.
  2560. There's an auxiliary array |randoms| that contains 55 pseudo-random
  2561. fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-24})\bmod 2^{28}$,
  2562. we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
  2563. The global variable |j_random| tells which element has most recently
  2564. been consumed.
  2565. @<Glob...@>=
  2566. @!randoms:array[0..54] of fraction; {the last 55 random values generated}
  2567. @!j_random:0..54; {the number of unused |randoms|}
  2568. @ To consume a random fraction, the program below will say `|next_random|'
  2569. and then it will fetch |randoms[j_random]|. The |next_random| macro
  2570. actually accesses the numbers backwards; blocks of 55~$x$'s are
  2571. essentially being ``flipped.'' But that doesn't make them less random.
  2572. @d next_random==if j_random=0 then new_randoms
  2573.   else decr(j_random)
  2574. @p procedure new_randoms;
  2575. var @!k:0..54; {index into |randoms|}
  2576. @!x:fraction; {accumulator}
  2577. begin for k:=0 to 23 do
  2578.   begin x:=randoms[k]-randoms[k+31];
  2579.   if x<0 then x:=x+fraction_one;
  2580.   randoms[k]:=x;
  2581.   end;
  2582. for k:=24 to 54 do
  2583.   begin x:=randoms[k]-randoms[k-24];
  2584.   if x<0 then x:=x+fraction_one;
  2585.   randoms[k]:=x;
  2586.   end;
  2587. j_random:=54;
  2588. @ To initialize the |randoms| table, we call the following routine.
  2589. @p procedure init_randoms(@!seed:scaled);
  2590. var @!j,@!jj,@!k:fraction; {more or less random integers}
  2591. @!i:0..54; {index into |randoms|}
  2592. begin j:=abs(seed);
  2593. while j>=fraction_one do j:=half(j);
  2594. k:=1;
  2595. for i:=0 to 54 do
  2596.   begin jj:=k; k:=j-k; j:=jj;
  2597.   if k<0 then k:=k+fraction_one;
  2598.   randoms[(i*21)mod 55]:=j;
  2599.   end;
  2600. new_randoms; new_randoms; new_randoms; {``warm up'' the array}
  2601. @ To produce a uniform random number in the range |0<=u<x| or |0>=u>x|
  2602. or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here.
  2603. Note that the call of |take_fraction| will produce the values 0 and~|x|
  2604. with about half the probability that it will produce any other particular
  2605. values between 0 and~|x|, because it rounds its answers.
  2606. @p function unif_rand(@!x:scaled):scaled;
  2607. var @!y:scaled; {trial value}
  2608. begin next_random; y:=take_fraction(abs(x),randoms[j_random]);
  2609. if y=abs(x) then unif_rand:=0
  2610. else if x>0 then unif_rand:=y
  2611. else unif_rand:=-y;
  2612. @ Finally, a normal deviate with mean zero and unit standard deviation
  2613. can readily be obtained with the ratio method (Algorithm 3.4.1R in
  2614. {\sl The Art of Computer Programming\/}).
  2615. @p function norm_rand:scaled;
  2616. var @!x,@!u,@!l:integer; {what the book would call $2^{16}X$, $2^{28}U$,
  2617.   and $-2^{24}\ln U$}
  2618. begin repeat
  2619.   repeat next_random;
  2620.   x:=take_fraction(112429,randoms[j_random]-fraction_half);
  2621.     {$2^{16}\sqrt{8/e}\approx 112428.82793$}
  2622.   next_random; u:=randoms[j_random];
  2623.   until abs(x)<u;
  2624. x:=make_fraction(x,u);
  2625. l:=139548960-m_log(u); {$2^{24}\cdot12\ln2\approx139548959.6165$}
  2626. until ab_vs_cd(1024,l,x,x)>=0;
  2627. norm_rand:=x;
  2628. @* \[9] Packed data.
  2629. In order to make efficient use of storage space, \MF\ bases its major data
  2630. structures on a |memory_word|, which contains either a (signed) integer,
  2631. possibly scaled, or a small number of fields that are one half or one
  2632. quarter of the size used for storing integers.
  2633. If |x| is a variable of type |memory_word|, it contains up to four
  2634. fields that can be referred to as follows:
  2635. $$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr
  2636. |x|&.|int|&(an |integer|)\cr
  2637. |x|&.|sc|\qquad&(a |scaled| integer)\cr
  2638. |x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr
  2639. |x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword
  2640.   field)\cr
  2641. |x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt
  2642.   &\qquad\qquad\qquad(four quarterword fields)\cr}}$$
  2643. This is somewhat cumbersome to write, and not very readable either, but
  2644. macros will be used to make the notation shorter and more transparent.
  2645. The \PASCAL\ code below gives a formal definition of |memory_word| and
  2646. its subsidiary types, using packed variant records. \MF\ makes no
  2647. assumptions about the relative positions of the fields within a word.
  2648. Since we are assuming 32-bit integers, a halfword must contain at least
  2649. 16 bits, and a quarterword must contain at least 8 bits.
  2650. @^system dependencies@>
  2651. But it doesn't hurt to have more bits; for example, with enough 36-bit
  2652. words you might be able to have |mem_max| as large as 262142.
  2653. N.B.: Valuable memory space will be dreadfully wasted unless \MF\ is compiled
  2654. by a \PASCAL\ that packs all of the |memory_word| variants into
  2655. the space of a single integer. Some \PASCAL\ compilers will pack an
  2656. integer whose subrange is `|0..255|' into an eight-bit field, but others
  2657. insist on allocating space for an additional sign bit; on such systems you
  2658. can get 256 values into a quarterword only if the subrange is `|-128..127|'.
  2659. The present implementation tries to accommodate as many variations as possible,
  2660. so it makes few assumptions. If integers having the subrange
  2661. `|min_quarterword..max_quarterword|' can be packed into a quarterword,
  2662. and if integers having the subrange `|min_halfword..max_halfword|'
  2663. can be packed into a halfword, everything should work satisfactorily.
  2664. It is usually most efficient to have |min_quarterword=min_halfword=0|,
  2665. so one should try to achieve this unless it causes a severe problem.
  2666. The values defined here are recommended for most 32-bit computers.
  2667. @d min_quarterword=0 {smallest allowable value in a |quarterword|}
  2668. @d max_quarterword=255 {largest allowable value in a |quarterword|}
  2669. @d min_halfword==0 {smallest allowable value in a |halfword|}
  2670. @d max_halfword==65535 {largest allowable value in a |halfword|}
  2671. @ Here are the inequalities that the quarterword and halfword values
  2672. must satisfy (or rather, the inequalities that they mustn't satisfy):
  2673. @<Check the ``constant''...@>=
  2674. init if mem_max<>mem_top then bad:=10;@+tini@;@/
  2675. if mem_max<mem_top then bad:=10;
  2676. if (min_quarterword>0)or(max_quarterword<127) then bad:=11;
  2677. if (min_halfword>0)or(max_halfword<32767) then bad:=12;
  2678. if (min_quarterword<min_halfword)or@|
  2679.   (max_quarterword>max_halfword) then bad:=13;
  2680. if (mem_min<min_halfword)or(mem_max>=max_halfword) then bad:=14;
  2681. if max_strings>max_halfword then bad:=15;
  2682. if buf_size>max_halfword then bad:=16;
  2683. if (max_quarterword-min_quarterword<255)or@|
  2684.   (max_halfword-min_halfword<65535) then bad:=17;
  2685. @ The operation of subtracting |min_halfword| occurs rather frequently in
  2686. \MF, so it is convenient to abbreviate this operation by using the macro
  2687. |ho| defined here.  \MF\ will run faster with respect to compilers that
  2688. don't optimize the expression `|x-0|', if this macro is simplified in the
  2689. obvious way when |min_halfword=0|. Similarly, |qi| and |qo| are used for
  2690. input to and output from quarterwords.
  2691. @^system dependencies@>
  2692. @d ho(#)==#-min_halfword
  2693.   {to take a sixteen-bit item from a halfword}
  2694. @d qo(#)==#-min_quarterword {to read eight bits from a quarterword}
  2695. @d qi(#)==#+min_quarterword {to store eight bits in a quarterword}
  2696. @ The reader should study the following definitions closely:
  2697. @^system dependencies@>
  2698. @d sc==int {|scaled| data is equivalent to |integer|}
  2699. @<Types...@>=
  2700. @!quarterword = min_quarterword..max_quarterword; {1/4 of a word}
  2701. @!halfword=min_halfword..max_halfword; {1/2 of a word}
  2702. @!two_choices = 1..2; {used when there are two variants in a record}
  2703. @!three_choices = 1..3; {used when there are three variants in a record}
  2704. @!two_halves = packed record@;@/
  2705.   @!rh:halfword;
  2706.   case two_choices of
  2707.   1: (@!lh:halfword);
  2708.   2: (@!b0:quarterword; @!b1:quarterword);
  2709.   end;
  2710. @!four_quarters = packed record@;@/
  2711.   @!b0:quarterword;
  2712.   @!b1:quarterword;
  2713.   @!b2:quarterword;
  2714.   @!b3:quarterword;
  2715.   end;
  2716. @!memory_word = record@;@/
  2717.   case three_choices of
  2718.   1: (@!int:integer);
  2719.   2: (@!hh:two_halves);
  2720.   3: (@!qqqq:four_quarters);
  2721.   end;
  2722. @!word_file = file of memory_word;
  2723. @ When debugging, we may want to print a |memory_word| without knowing
  2724. what type it is; so we print it in all modes.
  2725. @^dirty \PASCAL@>@^debugging@>
  2726. @p @!debug procedure print_word(@!w:memory_word);
  2727.   {prints |w| in all ways}
  2728. begin print_int(w.int); print_char(" ");@/
  2729. print_scaled(w.sc); print_char(" "); print_scaled(w.sc div @'10000); print_ln;@/
  2730. print_int(w.hh.lh); print_char("="); print_int(w.hh.b0); print_char(":");
  2731. print_int(w.hh.b1); print_char(";"); print_int(w.hh.rh); print_char(" ");@/
  2732. print_int(w.qqqq.b0); print_char(":"); print_int(w.qqqq.b1); print_char(":");
  2733. print_int(w.qqqq.b2); print_char(":"); print_int(w.qqqq.b3);
  2734. gubed
  2735. @* \[10] Dynamic memory allocation.
  2736. The \MF\ system does nearly all of its own memory allocation, so that it
  2737. can readily be transported into environments that do not have automatic
  2738. facilities for strings, garbage collection, etc., and so that it can be in
  2739. control of what error messages the user receives. The dynamic storage
  2740. requirements of \MF\ are handled by providing a large array |mem| in
  2741. which consecutive blocks of words are used as nodes by the \MF\ routines.
  2742. Pointer variables are indices into this array, or into another array
  2743. called |eqtb| that will be explained later. A pointer variable might
  2744. also be a special flag that lies outside the bounds of |mem|, so we
  2745. allow pointers to assume any |halfword| value. The minimum memory
  2746. index represents a null pointer.
  2747. @d pointer==halfword {a flag or a location in |mem| or |eqtb|}
  2748. @d null==mem_min {the null pointer}
  2749. @ The |mem| array is divided into two regions that are allocated separately,
  2750. but the dividing line between these two regions is not fixed; they grow
  2751. together until finding their ``natural'' size in a particular job.
  2752. Locations less than or equal to |lo_mem_max| are used for storing
  2753. variable-length records consisting of two or more words each. This region
  2754. is maintained using an algorithm similar to the one described in exercise
  2755. 2.5--19 of {\sl The Art of Computer Programming}. However, no size field
  2756. appears in the allocated nodes; the program is responsible for knowing the
  2757. relevant size when a node is freed. Locations greater than or equal to
  2758. |hi_mem_min| are used for storing one-word records; a conventional
  2759. \.{AVAIL} stack is used for allocation in this region.
  2760. Locations of |mem| between |mem_min| and |mem_top| may be dumped as part
  2761. of preloaded format files, by the \.{INIMF} preprocessor.
  2762. @.INIMF@>
  2763. Production versions of \MF\ may extend the memory at the top end in order to
  2764. provide more space; these locations, between |mem_top| and |mem_max|,
  2765. are always used for single-word nodes.
  2766. The key pointers that govern |mem| allocation have a prescribed order:
  2767. $$\hbox{|null=mem_min<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$
  2768. @<Glob...@>=
  2769. @!mem : array[mem_min..mem_max] of memory_word; {the big dynamic storage area}
  2770. @!lo_mem_max : pointer; {the largest location of variable-size memory in use}
  2771. @!hi_mem_min : pointer; {the smallest location of one-word memory in use}
  2772. @ Users who wish to study the memory requirements of specific applications can
  2773. use optional special features that keep track of current and
  2774. maximum memory usage. When code between the delimiters |@!stat| $\ldots$
  2775. |tats| is not ``commented out,'' \MF\ will run a bit slower but it will
  2776. report these statistics when |tracing_stats| is positive.
  2777. @<Glob...@>=
  2778. @!var_used, @!dyn_used : integer; {how much memory is in use}
  2779. @ Let's consider the one-word memory region first, since it's the
  2780. simplest. The pointer variable |mem_end| holds the highest-numbered location
  2781. of |mem| that has ever been used. The free locations of |mem| that
  2782. occur between |hi_mem_min| and |mem_end|, inclusive, are of type
  2783. |two_halves|, and we write |info(p)| and |link(p)| for the |lh|
  2784. and |rh| fields of |mem[p]| when it is of this type. The single-word
  2785. free locations form a linked list
  2786. $$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$
  2787. terminated by |null|.
  2788. @d link(#) == mem[#].hh.rh {the |link| field of a memory word}
  2789. @d info(#) == mem[#].hh.lh {the |info| field of a memory word}
  2790. @<Glob...@>=
  2791. @!avail : pointer; {head of the list of available one-word nodes}
  2792. @!mem_end : pointer; {the last one-word node used in |mem|}
  2793. @ If one-word memory is exhausted, it might mean that the user has forgotten
  2794. a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures
  2795. later that try to help pinpoint the trouble.
  2796. @p @t\4@>@<Declare the procedure called |show_token_list|@>@;
  2797. @t\4@>@<Declare the procedure called |runaway|@>
  2798. @ The function |get_avail| returns a pointer to a new one-word node whose
  2799. |link| field is null. However, \MF\ will halt if there is no more room left.
  2800. @^inner loop@>
  2801. @p function get_avail : pointer; {single-word node allocation}
  2802. var @!p:pointer; {the new node being got}
  2803. begin p:=avail; {get top location in the |avail| stack}
  2804. if p<>null then avail:=link(avail) {and pop it off}
  2805. else if mem_end<mem_max then {or go into virgin territory}
  2806.   begin incr(mem_end); p:=mem_end;
  2807.   end
  2808. else   begin decr(hi_mem_min); p:=hi_mem_min;
  2809.   if hi_mem_min<=lo_mem_max then
  2810.     begin runaway; {if memory is exhausted, display possible runaway text}
  2811.     overflow("main memory size",mem_max+1-mem_min);
  2812.       {quit; all one-word nodes are busy}
  2813. @:METAFONT capacity exceeded main memory size}{\quad main memory size@>
  2814.     end;
  2815.   end;
  2816. link(p):=null; {provide an oft-desired initialization of the new node}
  2817. @!stat incr(dyn_used);@+tats@;{maintain statistics}
  2818. get_avail:=p;
  2819. @ Conversely, a one-word node is recycled by calling |free_avail|.
  2820. @d free_avail(#)== {single-word node liberation}
  2821.   begin link(#):=avail; avail:=#;
  2822.   @!stat decr(dyn_used);@+tats@/
  2823.   end
  2824. @ There's also a |fast_get_avail| routine, which saves the procedure-call
  2825. overhead at the expense of extra programming. This macro is used in
  2826. the places that would otherwise account for the most calls of |get_avail|.
  2827. @^inner loop@>
  2828. @d fast_get_avail(#)==@t@>@;@/
  2829.   begin #:=avail; {avoid |get_avail| if possible, to save time}
  2830.   if #=null then #:=get_avail
  2831.   else  begin avail:=link(#); link(#):=null;
  2832.     @!stat incr(dyn_used);@+tats@/
  2833.     end;
  2834.   end
  2835. @ The available-space list that keeps track of the variable-size portion
  2836. of |mem| is a nonempty, doubly-linked circular list of empty nodes,
  2837. pointed to by the roving pointer |rover|.
  2838. Each empty node has size 2 or more; the first word contains the special
  2839. value |max_halfword| in its |link| field and the size in its |info| field;
  2840. the second word contains the two pointers for double linking.
  2841. Each nonempty node also has size 2 or more. Its first word is of type
  2842. |two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|.
  2843. Otherwise there is complete flexibility with respect to the contents
  2844. of its other fields and its other words.
  2845. (We require |mem_max<max_halfword| because terrible things can happen
  2846. when |max_halfword| appears in the |link| field of a nonempty node.)
  2847. @d empty_flag == max_halfword {the |link| of an empty variable-size node}
  2848. @d is_empty(#) == (link(#)=empty_flag) {tests for empty node}
  2849. @d node_size == info {the size field in empty variable-size nodes}
  2850. @d llink(#) == info(#+1) {left link in doubly-linked list of empty nodes}
  2851. @d rlink(#) == link(#+1) {right link in doubly-linked list of empty nodes}
  2852. @<Glob...@>=
  2853. @!rover : pointer; {points to some node in the list of empties}
  2854. @ A call to |get_node| with argument |s| returns a pointer to a new node
  2855. of size~|s|, which must be 2~or more. The |link| field of the first word
  2856. of this new node is set to null. An overflow stop occurs if no suitable
  2857. space exists.
  2858. If |get_node| is called with $s=2^{30}$, it simply merges adjacent free
  2859. areas and returns the value |max_halfword|.
  2860. @p function get_node(@!s:integer):pointer; {variable-size node allocation}
  2861. label found,exit,restart;
  2862. var @!p:pointer; {the node currently under inspection}
  2863. @!q:pointer; {the node physically after node |p|}
  2864. @!r:integer; {the newly allocated node, or a candidate for this honor}
  2865. @!t,@!tt:integer; {temporary registers}
  2866. @^inner loop@>
  2867. begin restart: p:=rover; {start at some free node in the ring}
  2868. repeat @<Try to allocate within node |p| and its physical successors,
  2869.   and |goto found| if allocation was possible@>;
  2870. p:=rlink(p); {move to the next node in the ring}
  2871. until p=rover; {repeat until the whole list has been traversed}
  2872. if s=@'10000000000 then
  2873.   begin get_node:=max_halfword; return;
  2874.   end;
  2875. if lo_mem_max+2<hi_mem_min then if lo_mem_max+2<=mem_min+max_halfword then
  2876.   @<Grow more variable-size memory and |goto restart|@>;
  2877. overflow("main memory size",mem_max+1-mem_min);
  2878.   {sorry, nothing satisfactory is left}
  2879. @:METAFONT capacity exceeded main memory size}{\quad main memory size@>
  2880. found: link(r):=null; {this node is now nonempty}
  2881. @!stat var_used:=var_used+s; {maintain usage statistics}
  2882. tats@;@/
  2883. get_node:=r;
  2884. exit:end;
  2885. @ The lower part of |mem| grows by 1000 words at a time, unless
  2886. we are very close to going under. When it grows, we simply link
  2887. a new node into the available-space list. This method of controlled
  2888. growth helps to keep the |mem| usage consecutive when \MF\ is
  2889. implemented on ``virtual memory'' systems.
  2890. @^virtual memory@>
  2891. @<Grow more variable-size memory and |goto restart|@>=
  2892. begin if hi_mem_min-lo_mem_max>=1998 then t:=lo_mem_max+1000
  2893. else t:=lo_mem_max+1+(hi_mem_min-lo_mem_max) div 2;
  2894.   {|lo_mem_max+2<=t<hi_mem_min|}
  2895. if t>mem_min+max_halfword then t:=mem_min+max_halfword;
  2896. p:=llink(rover); q:=lo_mem_max; rlink(p):=q; llink(rover):=q;@/
  2897. rlink(q):=rover; llink(q):=p; link(q):=empty_flag; node_size(q):=t-lo_mem_max;@/
  2898. lo_mem_max:=t; link(lo_mem_max):=null; info(lo_mem_max):=null;
  2899. rover:=q; goto restart;
  2900. @ @<Try to allocate...@>=
  2901. q:=p+node_size(p); {find the physical successor}
  2902. while is_empty(q) do {merge node |p| with node |q|}
  2903.   begin t:=rlink(q); tt:=llink(q);
  2904. @^inner loop@>
  2905.   if q=rover then rover:=t;
  2906.   llink(t):=tt; rlink(tt):=t;@/
  2907.   q:=q+node_size(q);
  2908.   end;
  2909. r:=q-s;
  2910. if r>p+1 then @<Allocate from the top of node |p| and |goto found|@>;
  2911. if r=p then if rlink(p)<>p then
  2912.   @<Allocate entire node |p| and |goto found|@>;
  2913. node_size(p):=q-p {reset the size in case it grew}
  2914. @ @<Allocate from the top...@>=
  2915. begin node_size(p):=r-p; {store the remaining size}
  2916. rover:=p; {start searching here next time}
  2917. goto found;
  2918. @ Here we delete node |p| from the ring, and let |rover| rove around.
  2919. @<Allocate entire...@>=
  2920. begin rover:=rlink(p); t:=llink(p);
  2921. llink(rover):=t; rlink(t):=rover;
  2922. goto found;
  2923. @ Conversely, when some variable-size node |p| of size |s| is no longer needed,
  2924. the operation |free_node(p,s)| will make its words available, by inserting
  2925. |p| as a new empty node just before where |rover| now points.
  2926. @p procedure free_node(@!p:pointer; @!s:halfword); {variable-size node
  2927.   liberation}
  2928. var @!q:pointer; {|llink(rover)|}
  2929. begin node_size(p):=s; link(p):=empty_flag;
  2930. @^inner loop@>
  2931. q:=llink(rover); llink(p):=q; rlink(p):=rover; {set both links}
  2932. llink(rover):=p; rlink(q):=p; {insert |p| into the ring}
  2933. @!stat var_used:=var_used-s;@+tats@;{maintain statistics}
  2934. @ Just before \.{INIMF} writes out the memory, it sorts the doubly linked
  2935. available space list. The list is probably very short at such times, so a
  2936. simple insertion sort is used. The smallest available location will be
  2937. pointed to by |rover|, the next-smallest by |rlink(rover)|, etc.
  2938. @p @!init procedure sort_avail; {sorts the available variable-size nodes
  2939.   by location}
  2940. var @!p,@!q,@!r: pointer; {indices into |mem|}
  2941. @!old_rover:pointer; {initial |rover| setting}
  2942. begin p:=get_node(@'10000000000); {merge adjacent free areas}
  2943. p:=rlink(rover); rlink(rover):=max_halfword; old_rover:=rover;
  2944. while p<>old_rover do @<Sort |p| into the list starting at |rover|
  2945.   and advance |p| to |rlink(p)|@>;
  2946. p:=rover;
  2947. while rlink(p)<>max_halfword do
  2948.   begin llink(rlink(p)):=p; p:=rlink(p);
  2949.   end;
  2950. rlink(p):=rover; llink(rover):=p;
  2951. @ The following |while| loop is guaranteed to
  2952. terminate, since the list that starts at
  2953. |rover| ends with |max_halfword| during the sorting procedure.
  2954. @<Sort |p|...@>=
  2955. if p<rover then
  2956.   begin q:=p; p:=rlink(q); rlink(q):=rover; rover:=q;
  2957.   end
  2958. else  begin q:=rover;
  2959.   while rlink(q)<p do q:=rlink(q);
  2960.   r:=rlink(p); rlink(p):=rlink(q); rlink(q):=p; p:=r;
  2961.   end
  2962. @* \[11] Memory layout.
  2963. Some areas of |mem| are dedicated to fixed usage, since static allocation is
  2964. more efficient than dynamic allocation when we can get away with it. For
  2965. example, locations |mem_min| to |mem_min+2| are always used to store the
  2966. specification for null pen coordinates that are `$(0,0)$'. The
  2967. following macro definitions accomplish the static allocation by giving
  2968. symbolic names to the fixed positions. Static variable-size nodes appear
  2969. in locations |mem_min| through |lo_mem_stat_max|, and static single-word nodes
  2970. appear in locations |hi_mem_stat_min| through |mem_top|, inclusive.
  2971. @d null_coords==mem_min {specification for pen offsets of $(0,0)$}
  2972. @d null_pen==null_coords+3 {we will define |coord_node_size=3|}
  2973. @d dep_head==null_pen+10 {and |pen_node_size=10|}
  2974. @d zero_val==dep_head+2 {two words for a permanently zero value}
  2975. @d temp_val==zero_val+2 {two words for a temporary value node}
  2976. @d end_attr==temp_val {we use |end_attr+2| only}
  2977. @d inf_val==end_attr+2 {and |inf_val+1| only}
  2978. @d bad_vardef==inf_val+2 {two words for \&{vardef} error recovery}
  2979. @d lo_mem_stat_max==bad_vardef+1  {largest statically
  2980.   allocated word in the variable-size |mem|}
  2981. @d sentinel==mem_top {end of sorted lists}
  2982. @d temp_head==mem_top-1 {head of a temporary list of some kind}
  2983. @d hold_head==mem_top-2 {head of a temporary list of another kind}
  2984. @d hi_mem_stat_min==mem_top-2 {smallest statically allocated word in
  2985.   the one-word |mem|}
  2986. @ The following code gets the dynamic part of |mem| off to a good start,
  2987. when \MF\ is initializing itself the slow way.
  2988. @<Initialize table entries (done by \.{INIMF} only)@>=
  2989. @^data structure assumptions@>
  2990. rover:=lo_mem_stat_max+1; {initialize the dynamic memory}
  2991. link(rover):=empty_flag;
  2992. node_size(rover):=1000; {which is a 1000-word available node}
  2993. llink(rover):=rover; rlink(rover):=rover;@/
  2994. lo_mem_max:=rover+1000; link(lo_mem_max):=null; info(lo_mem_max):=null;@/
  2995. for k:=hi_mem_stat_min to mem_top do
  2996.   mem[k]:=mem[lo_mem_max]; {clear list heads}
  2997. avail:=null; mem_end:=mem_top;
  2998. hi_mem_min:=hi_mem_stat_min; {initialize the one-word memory}
  2999. var_used:=lo_mem_stat_max+1-mem_min; dyn_used:=mem_top+1-hi_mem_min;
  3000.   {initialize statistics}
  3001. @ The procedure |flush_list(p)| frees an entire linked list of one-word
  3002. nodes that starts at a given position, until coming to |sentinel| or a
  3003. pointer that is not in the one-word region. Another procedure,
  3004. |flush_node_list|, frees an entire linked list of one-word and two-word
  3005. nodes, until coming to a |null| pointer.
  3006. @^inner loop@>
  3007. @p procedure flush_list(@!p:pointer); {makes list of single-word nodes
  3008.   available}
  3009. label done;
  3010. var @!q,@!r:pointer; {list traversers}
  3011. begin if p>=hi_mem_min then if p<>sentinel then
  3012.   begin r:=p;
  3013.   repeat q:=r; r:=link(r); @!stat decr(dyn_used);@+tats@/
  3014.   if r<hi_mem_min then goto done;
  3015.   until r=sentinel;
  3016.   done: {now |q| is the last node on the list}
  3017.   link(q):=avail; avail:=p;
  3018.   end;
  3019. procedure flush_node_list(@!p:pointer);
  3020. var @!q:pointer; {the node being recycled}
  3021. begin while p<>null do
  3022.   begin q:=p; p:=link(p);
  3023.   if q<hi_mem_min then free_node(q,2)@+else free_avail(q);
  3024.   end;
  3025. @ If \MF\ is extended improperly, the |mem| array might get screwed up.
  3026. For example, some pointers might be wrong, or some ``dead'' nodes might not
  3027. have been freed when the last reference to them disappeared. Procedures
  3028. |check_mem| and |search_mem| are available to help diagnose such
  3029. problems. These procedures make use of two arrays called |free| and
  3030. |was_free| that are present only if \MF's debugging routines have
  3031. been included. (You may want to decrease the size of |mem| while you
  3032. @^debugging@>
  3033. are debugging.)
  3034. @<Glob...@>=
  3035. @!debug @!free: packed array [mem_min..mem_max] of boolean; {free cells}
  3036. @t\hskip1em@>@!was_free: packed array [mem_min..mem_max] of boolean;
  3037.   {previously free cells}
  3038. @t\hskip1em@>@!was_mem_end,@!was_lo_max,@!was_hi_min: pointer;
  3039.   {previous |mem_end|, |lo_mem_max|,and |hi_mem_min|}
  3040. @t\hskip1em@>@!panicking:boolean; {do we want to check memory constantly?}
  3041. gubed
  3042. @ @<Set initial...@>=
  3043. @!debug was_mem_end:=mem_min; {indicate that everything was previously free}
  3044. was_lo_max:=mem_min; was_hi_min:=mem_max;
  3045. panicking:=false;
  3046. gubed
  3047. @ Procedure |check_mem| makes sure that the available space lists of
  3048. |mem| are well formed, and it optionally prints out all locations
  3049. that are reserved now but were free the last time this procedure was called.
  3050. @p @!debug procedure check_mem(@!print_locs : boolean);
  3051. label done1,done2; {loop exits}
  3052. var @!p,@!q,@!r:pointer; {current locations of interest in |mem|}
  3053. @!clobbered:boolean; {is something amiss?}
  3054. begin for p:=mem_min to lo_mem_max do free[p]:=false; {you can probably
  3055.   do this faster}
  3056. for p:=hi_mem_min to mem_end do free[p]:=false; {ditto}
  3057. @<Check single-word |avail| list@>;
  3058. @<Check variable-size |avail| list@>;
  3059. @<Check flags of unavailable nodes@>;
  3060. @<Check the list of linear dependencies@>;
  3061. if print_locs then @<Print newly busy locations@>;
  3062. for p:=mem_min to lo_mem_max do was_free[p]:=free[p];
  3063. for p:=hi_mem_min to mem_end do was_free[p]:=free[p];
  3064.   {|was_free:=free| might be faster}
  3065. was_mem_end:=mem_end; was_lo_max:=lo_mem_max; was_hi_min:=hi_mem_min;
  3066. gubed
  3067. @ @<Check single-word...@>=
  3068. p:=avail; q:=null; clobbered:=false;
  3069. while p<>null do
  3070.   begin if (p>mem_end)or(p<hi_mem_min) then clobbered:=true
  3071.   else if free[p] then clobbered:=true;
  3072.   if clobbered then
  3073.     begin print_nl("AVAIL list clobbered at ");
  3074. @.AVAIL list clobbered...@>
  3075.     print_int(q); goto done1;
  3076.     end;
  3077.   free[p]:=true; q:=p; p:=link(q);
  3078.   end;
  3079. done1:
  3080. @ @<Check variable-size...@>=
  3081. p:=rover; q:=null; clobbered:=false;
  3082. repeat if (p>=lo_mem_max)or(p<mem_min) then clobbered:=true
  3083.   else if (rlink(p)>=lo_mem_max)or(rlink(p)<mem_min) then clobbered:=true
  3084.   else if  not(is_empty(p))or(node_size(p)<2)or@|
  3085.    (p+node_size(p)>lo_mem_max)or@| (llink(rlink(p))<>p) then clobbered:=true;
  3086.   if clobbered then
  3087.   begin print_nl("Double-AVAIL list clobbered at ");
  3088. @.Double-AVAIL list clobbered...@>
  3089.   print_int(q); goto done2;
  3090.   end;
  3091. for q:=p to p+node_size(p)-1 do {mark all locations free}
  3092.   begin if free[q] then
  3093.     begin print_nl("Doubly free location at ");
  3094. @.Doubly free location...@>
  3095.     print_int(q); goto done2;
  3096.     end;
  3097.   free[q]:=true;
  3098.   end;
  3099. q:=p; p:=rlink(p);
  3100. until p=rover;
  3101. done2:
  3102. @ @<Check flags...@>=
  3103. p:=mem_min;
  3104. while p<=lo_mem_max do {node |p| should not be empty}
  3105.   begin if is_empty(p) then
  3106.     begin print_nl("Bad flag at "); print_int(p);
  3107. @.Bad flag...@>
  3108.     end;
  3109.   while (p<=lo_mem_max) and not free[p] do incr(p);
  3110.   while (p<=lo_mem_max) and free[p] do incr(p);
  3111.   end
  3112. @ @<Print newly busy...@>=
  3113. begin print_nl("New busy locs:");
  3114. @.New busy locs@>
  3115. for p:=mem_min to lo_mem_max do
  3116.   if not free[p] and ((p>was_lo_max) or was_free[p]) then
  3117.     begin print_char(" "); print_int(p);
  3118.     end;
  3119. for p:=hi_mem_min to mem_end do
  3120.   if not free[p] and
  3121.    ((p<was_hi_min) or (p>was_mem_end) or was_free[p]) then
  3122.     begin print_char(" "); print_int(p);
  3123.     end;
  3124. @ The |search_mem| procedure attempts to answer the question ``Who points
  3125. to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem|
  3126. that might not be of type |two_halves|. Strictly speaking, this is
  3127. @^dirty \PASCAL@>
  3128. undefined in \PASCAL, and it can lead to ``false drops'' (words that seem to
  3129. point to |p| purely by coincidence). But for debugging purposes, we want
  3130. to rule out the places that do {\sl not\/} point to |p|, so a few false
  3131. drops are tolerable.
  3132. @p @!debug procedure search_mem(@!p:pointer); {look for pointers to |p|}
  3133. var @!q:integer; {current position being searched}
  3134. begin for q:=mem_min to lo_mem_max do
  3135.   begin if link(q)=p then
  3136.     begin print_nl("LINK("); print_int(q); print_char(")");
  3137.     end;
  3138.   if info(q)=p then
  3139.     begin print_nl("INFO("); print_int(q); print_char(")");
  3140.     end;
  3141.   end;
  3142. for q:=hi_mem_min to mem_end do
  3143.   begin if link(q)=p then
  3144.     begin print_nl("LINK("); print_int(q); print_char(")");
  3145.     end;
  3146.   if info(q)=p then
  3147.     begin print_nl("INFO("); print_int(q); print_char(")");
  3148.     end;
  3149.   end;
  3150. @<Search |eqtb| for equivalents equal to |p|@>;
  3151. gubed
  3152. @* \[12] The command codes.
  3153. Before we can go much further, we need to define symbolic names for the internal
  3154. code numbers that represent the various commands obeyed by \MF. These codes
  3155. are somewhat arbitrary, but not completely so. For example,
  3156. some codes have been made adjacent so that |case| statements in the
  3157. program need not consider cases that are widely spaced, or so that |case|
  3158. statements can be replaced by |if| statements. A command can begin an
  3159. expression if and only if its code lies between |min_primary_command| and
  3160. |max_primary_command|, inclusive. The first token of a statement that doesn't
  3161. begin with an expression has a command code between |min_command| and
  3162. |max_statement_command|, inclusive. The ordering of the highest-numbered
  3163. commands (|comma<semicolon<end_group<stop|) is crucial for the parsing
  3164. and error-recovery methods of this program.
  3165. At any rate, here is the list, for future reference.
  3166. @d if_test=1 {conditional text (\&{if})}
  3167. @d fi_or_else=2 {delimiters for conditionals (\&{elseif}, \&{else}, \&{fi}}
  3168. @d input=3 {input a source file (\&{input}, \&{endinput})}
  3169. @d iteration=4 {iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor})}
  3170. @d repeat_loop=5 {special command substituted for \&{endfor}}
  3171. @d exit_test=6 {premature exit from a loop (\&{exitif})}
  3172. @d relax=7 {do nothing (\.{\char`\\})}
  3173. @d scan_tokens=8 {put a string into the input buffer}
  3174. @d expand_after=9 {look ahead one token}
  3175. @d defined_macro=10 {a macro defined by the user}
  3176. @d min_command=defined_macro+1
  3177. @d display_command=11 {online graphic output (\&{display})}
  3178. @d save_command=12 {save a list of tokens (\&{save})}
  3179. @d interim_command=13 {save an internal quantity (\&{interim})}
  3180. @d let_command=14 {redefine a symbolic token (\&{let})}
  3181. @d new_internal=15 {define a new internal quantity (\&{newinternal})}
  3182. @d macro_def=16 {define a macro (\&{def}, \&{vardef}, etc.)}
  3183. @d ship_out_command=17 {output a character (\&{shipout})}
  3184. @d add_to_command=18 {add to edges (\&{addto})}
  3185. @d cull_command=19 {cull and normalize edges (\&{cull})}
  3186. @d tfm_command=20 {command for font metric info (\&{ligtable}, etc.)}
  3187. @d protection_command=21 {set protection flag (\&{outer}, \&{inner})}
  3188. @d show_command=22 {diagnostic output (\&{show}, \&{showvariable}, etc.)}
  3189. @d mode_command=23 {set interaction level (\&{batchmode}, etc.)}
  3190. @d random_seed=24 {initialize random number generator (\&{randomseed})}
  3191. @d message_command=25 {communicate to user (\&{message}, \&{errmessage})}
  3192. @d every_job_command=26 {designate a starting token (\&{everyjob})}
  3193. @d delimiters=27 {define a pair of delimiters (\&{delimiters})}
  3194. @d open_window=28 {define a window on the screen (\&{openwindow})}
  3195. @d special_command=29 {output special info (\&{special}, \&{numspecial})}
  3196. @d type_name=30 {declare a type (\&{numeric}, \&{pair}, etc.}
  3197. @d max_statement_command=type_name
  3198. @d min_primary_command=type_name
  3199. @d left_delimiter=31 {the left delimiter of a matching pair}
  3200. @d begin_group=32 {beginning of a group (\&{begingroup})}
  3201. @d nullary=33 {an operator without arguments (e.g., \&{normaldeviate})}
  3202. @d unary=34 {an operator with one argument (e.g., \&{sqrt})}
  3203. @d str_op=35 {convert a suffix to a string (\&{str})}
  3204. @d cycle=36 {close a cyclic path (\&{cycle})}
  3205. @d primary_binary=37 {binary operation taking `\&{of}' (e.g., \&{point})}
  3206. @d capsule_token=38 {a value that has been put into a token list}
  3207. @d string_token=39 {a string constant (e.g., |"hello"|)}
  3208. @d internal_quantity=40 {internal numeric parameter (e.g., \&{pausing})}
  3209. @d min_suffix_token=internal_quantity
  3210. @d tag_token=41 {a symbolic token without a primitive meaning}
  3211. @d numeric_token=42 {a numeric constant (e.g., \.{3.14159})}
  3212. @d max_suffix_token=numeric_token
  3213. @d plus_or_minus=43 {either `\.+' or `\.-'}
  3214. @d max_primary_command=plus_or_minus {should also be |numeric_token+1|}
  3215. @d min_tertiary_command=plus_or_minus
  3216. @d tertiary_secondary_macro=44 {a macro defined by \&{secondarydef}}
  3217. @d tertiary_binary=45 {an operator at the tertiary level (e.g., `\.{++}')}
  3218. @d max_tertiary_command=tertiary_binary
  3219. @d left_brace=46 {the operator `\.{\char`\{}'}
  3220. @d min_expression_command=left_brace
  3221. @d path_join=47 {the operator `\.{..}'}
  3222. @d ampersand=48 {the operator `\.\&'}
  3223. @d expression_tertiary_macro=49 {a macro defined by \&{tertiarydef}}
  3224. @d expression_binary=50 {an operator at the expression level (e.g., `\.<')}
  3225. @d equals=51 {the operator `\.='}
  3226. @d max_expression_command=equals
  3227. @d and_command=52 {the operator `\&{and}'}
  3228. @d min_secondary_command=and_command
  3229. @d secondary_primary_macro=53 {a macro defined by \&{primarydef}}
  3230. @d slash=54 {the operator `\./'}
  3231. @d secondary_binary=55 {an operator at the binary level (e.g., \&{shifted})}
  3232. @d max_secondary_command=secondary_binary
  3233. @d param_type=56 {type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.)}
  3234. @d controls=57 {specify control points explicitly (\&{controls})}
  3235. @d tension=58 {specify tension between knots (\&{tension})}
  3236. @d at_least=59 {bounded tension value (\&{atleast})}
  3237. @d curl_command=60 {specify curl at an end knot (\&{curl})}
  3238. @d macro_special=61 {special macro operators (\&{quote}, \.{\#\AT!}, etc.)}
  3239. @d right_delimiter=62 {the right delimiter of a matching pair}
  3240. @d left_bracket=63 {the operator `\.['}
  3241. @d right_bracket=64 {the operator `\.]'}
  3242. @d right_brace=65 {the operator `\.{\char`\}}'}
  3243. @d with_option=66 {option for filling (\&{withpen}, \&{withweight})}
  3244. @d cull_op=67 {the operator `\&{keeping}' or `\&{dropping}'}
  3245. @d thing_to_add=68
  3246.   {variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also})}
  3247. @d of_token=69 {the operator `\&{of}'}
  3248. @d from_token=70 {the operator `\&{from}'}
  3249. @d to_token=71 {the operator `\&{to}'}
  3250. @d at_token=72 {the operator `\&{at}'}
  3251. @d in_window=73 {the operator `\&{inwindow}'}
  3252. @d step_token=74 {the operator `\&{step}'}
  3253. @d until_token=75 {the operator `\&{until}'}
  3254. @d lig_kern_token=76
  3255.   {the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}, etc.}
  3256. @d assignment=77 {the operator `\.{:=}'}
  3257. @d skip_to=78 {the operation `\&{skipto}'}
  3258. @d bchar_label=79 {the operator `\.{\char'174\char'174:}'}
  3259. @d double_colon=80 {the operator `\.{::}'}
  3260. @d colon=81 {the operator `\.:'}
  3261. @d comma=82 {the operator `\.,', must be |colon+1|}
  3262. @d end_of_statement==cur_cmd>comma
  3263. @d semicolon=83 {the operator `\.;', must be |comma+1|}
  3264. @d end_group=84 {end a group (\&{endgroup}), must be |semicolon+1|}
  3265. @d stop=85 {end a job (\&{end}, \&{dump}), must be |end_group+1|}
  3266. @d max_command_code=stop
  3267. @d outer_tag=max_command_code+1 {protection code added to command code}
  3268. @<Types...@>=
  3269. @!command_code=1..max_command_code;
  3270. @ Variables and capsules in \MF\ have a variety of ``types,''
  3271. distinguished by the following code numbers:
  3272. @d undefined=0 {no type has been declared}
  3273. @d unknown_tag=1 {this constant is added to certain type codes below}
  3274. @d vacuous=1 {no expression was present}
  3275. @d boolean_type=2 {\&{boolean} with a known value}
  3276. @d unknown_boolean=boolean_type+unknown_tag
  3277. @d string_type=4 {\&{string} with a known value}
  3278. @d unknown_string=string_type+unknown_tag
  3279. @d pen_type=6 {\&{pen} with a known value}
  3280. @d unknown_pen=pen_type+unknown_tag
  3281. @d future_pen=8 {subexpression that will become a \&{pen} at a higher level}
  3282. @d path_type=9 {\&{path} with a known value}
  3283. @d unknown_path=path_type+unknown_tag
  3284. @d picture_type=11 {\&{picture} with a known value}
  3285. @d unknown_picture=picture_type+unknown_tag
  3286. @d transform_type=13 {\&{transform} variable or capsule}
  3287. @d pair_type=14 {\&{pair} variable or capsule}
  3288. @d numeric_type=15 {variable that has been declared \&{numeric} but not used}
  3289. @d known=16 {\&{numeric} with a known value}
  3290. @d dependent=17 {a linear combination with |fraction| coefficients}
  3291. @d proto_dependent=18 {a linear combination with |scaled| coefficients}
  3292. @d independent=19 {\&{numeric} with unknown value}
  3293. @d token_list=20 {variable name or suffix argument or text argument}
  3294. @d structured=21 {variable with subscripts and attributes}
  3295. @d unsuffixed_macro=22 {variable defined with \&{vardef} but no \.{\AT!\#}}
  3296. @d suffixed_macro=23 {variable defined with \&{vardef} and \.{\AT!\#}}
  3297. @d unknown_types==unknown_boolean,unknown_string,
  3298.   unknown_pen,unknown_picture,unknown_path
  3299. @<Basic printing procedures@>=
  3300. procedure print_type(@!t:small_number);
  3301. begin case t of
  3302. vacuous:print("vacuous");
  3303. boolean_type:print("boolean");
  3304. unknown_boolean:print("unknown boolean");
  3305. string_type:print("string");
  3306. unknown_string:print("unknown string");
  3307. pen_type:print("pen");
  3308. unknown_pen:print("unknown pen");
  3309. future_pen:print("future pen");
  3310. path_type:print("path");
  3311. unknown_path:print("unknown path");
  3312. picture_type:print("picture");
  3313. unknown_picture:print("unknown picture");
  3314. transform_type:print("transform");
  3315. pair_type:print("pair");
  3316. known:print("known numeric");
  3317. dependent:print("dependent");
  3318. proto_dependent:print("proto-dependent");
  3319. numeric_type:print("numeric");
  3320. independent:print("independent");
  3321. token_list:print("token list");
  3322. structured:print("structured");
  3323. unsuffixed_macro:print("unsuffixed macro");
  3324. suffixed_macro:print("suffixed macro");
  3325. othercases print("undefined")
  3326. endcases;
  3327. @ Values inside \MF\ are stored in two-word nodes that have a |name_type|
  3328. as well as a |type|. The possibilities for |name_type| are defined
  3329. here; they will be explained in more detail later.
  3330. @d root=0 {|name_type| at the top level of a variable}
  3331. @d saved_root=1 {same, when the variable has been saved}
  3332. @d structured_root=2 {|name_type| where a |structured| branch occurs}
  3333. @d subscr=3 {|name_type| in a subscript node}
  3334. @d attr=4 {|name_type| in an attribute node}
  3335. @d x_part_sector=5 {|name_type| in the \&{xpart} of a node}
  3336. @d y_part_sector=6 {|name_type| in the \&{ypart} of a node}
  3337. @d xx_part_sector=7 {|name_type| in the \&{xxpart} of a node}
  3338. @d xy_part_sector=8 {|name_type| in the \&{xypart} of a node}
  3339. @d yx_part_sector=9 {|name_type| in the \&{yxpart} of a node}
  3340. @d yy_part_sector=10 {|name_type| in the \&{yypart} of a node}
  3341. @d capsule=11 {|name_type| in stashed-away subexpressions}
  3342. @d token=12 {|name_type| in a numeric token or string token}
  3343. @ Primitive operations that produce values have a secondary identification
  3344. code in addition to their command code; it's something like genera and species.
  3345. For example, `\.*' has the command code |primary_binary|, and its
  3346. secondary identification is |times|. The secondary codes start at 30 so that
  3347. they don't overlap with the type codes; some type codes (e.g., |string_type|)
  3348. are used as operators as well as type identifications.
  3349. @d true_code=30 {operation code for \.{true}}
  3350. @d false_code=31 {operation code for \.{false}}
  3351. @d null_picture_code=32 {operation code for \.{nullpicture}}
  3352. @d null_pen_code=33 {operation code for \.{nullpen}}
  3353. @d job_name_op=34 {operation code for \.{jobname}}
  3354. @d read_string_op=35 {operation code for \.{readstring}}
  3355. @d pen_circle=36 {operation code for \.{pencircle}}
  3356. @d normal_deviate=37 {operation code for \.{normaldeviate}}
  3357. @d odd_op=38 {operation code for \.{odd}}
  3358. @d known_op=39 {operation code for \.{known}}
  3359. @d unknown_op=40 {operation code for \.{unknown}}
  3360. @d not_op=41 {operation code for \.{not}}
  3361. @d decimal=42 {operation code for \.{decimal}}
  3362. @d reverse=43 {operation code for \.{reverse}}
  3363. @d make_path_op=44 {operation code for \.{makepath}}
  3364. @d make_pen_op=45 {operation code for \.{makepen}}
  3365. @d total_weight_op=46 {operation code for \.{totalweight}}
  3366. @d oct_op=47 {operation code for \.{oct}}
  3367. @d hex_op=48 {operation code for \.{hex}}
  3368. @d ASCII_op=49 {operation code for \.{ASCII}}
  3369. @d char_op=50 {operation code for \.{char}}
  3370. @d length_op=51 {operation code for \.{length}}
  3371. @d turning_op=52 {operation code for \.{turningnumber}}
  3372. @d x_part=53 {operation code for \.{xpart}}
  3373. @d y_part=54 {operation code for \.{ypart}}
  3374. @d xx_part=55 {operation code for \.{xxpart}}
  3375. @d xy_part=56 {operation code for \.{xypart}}
  3376. @d yx_part=57 {operation code for \.{yxpart}}
  3377. @d yy_part=58 {operation code for \.{yypart}}
  3378. @d sqrt_op=59 {operation code for \.{sqrt}}
  3379. @d m_exp_op=60 {operation code for \.{mexp}}
  3380. @d m_log_op=61 {operation code for \.{mlog}}
  3381. @d sin_d_op=62 {operation code for \.{sind}}
  3382. @d cos_d_op=63 {operation code for \.{cosd}}
  3383. @d floor_op=64 {operation code for \.{floor}}
  3384. @d uniform_deviate=65 {operation code for \.{uniformdeviate}}
  3385. @d char_exists_op=66 {operation code for \.{charexists}}
  3386. @d angle_op=67 {operation code for \.{angle}}
  3387. @d cycle_op=68 {operation code for \.{cycle}}
  3388. @d plus=69 {operation code for \.+}
  3389. @d minus=70 {operation code for \.-}
  3390. @d times=71 {operation code for \.*}
  3391. @d over=72 {operation code for \./}
  3392. @d pythag_add=73 {operation code for \.{++}}
  3393. @d pythag_sub=74 {operation code for \.{+-+}}
  3394. @d or_op=75 {operation code for \.{or}}
  3395. @d and_op=76 {operation code for \.{and}}
  3396. @d less_than=77 {operation code for \.<}
  3397. @d less_or_equal=78 {operation code for \.{<=}}
  3398. @d greater_than=79 {operation code for \.>}
  3399. @d greater_or_equal=80 {operation code for \.{>=}}
  3400. @d equal_to=81 {operation code for \.=}
  3401. @d unequal_to=82 {operation code for \.{<>}}
  3402. @d concatenate=83 {operation code for \.\&}
  3403. @d rotated_by=84 {operation code for \.{rotated}}
  3404. @d slanted_by=85 {operation code for \.{slanted}}
  3405. @d scaled_by=86 {operation code for \.{scaled}}
  3406. @d shifted_by=87 {operation code for \.{shifted}}
  3407. @d transformed_by=88 {operation code for \.{transformed}}
  3408. @d x_scaled=89 {operation code for \.{xscaled}}
  3409. @d y_scaled=90 {operation code for \.{yscaled}}
  3410. @d z_scaled=91 {operation code for \.{zscaled}}
  3411. @d intersect=92 {operation code for \.{intersectiontimes}}
  3412. @d double_dot=93 {operation code for improper \.{..}}
  3413. @d substring_of=94 {operation code for \.{substring}}
  3414. @d min_of=substring_of
  3415. @d subpath_of=95 {operation code for \.{subpath}}
  3416. @d direction_time_of=96 {operation code for \.{directiontime}}
  3417. @d point_of=97 {operation code for \.{point}}
  3418. @d precontrol_of=98 {operation code for \.{precontrol}}
  3419. @d postcontrol_of=99 {operation code for \.{postcontrol}}
  3420. @d pen_offset_of=100 {operation code for \.{penoffset}}
  3421. @p procedure print_op(@!c:quarterword);
  3422. begin if c<=numeric_type then print_type(c)
  3423. else case c of
  3424. true_code:print("true");
  3425. false_code:print("false");
  3426. null_picture_code:print("nullpicture");
  3427. null_pen_code:print("nullpen");
  3428. job_name_op:print("jobname");
  3429. read_string_op:print("readstring");
  3430. pen_circle:print("pencircle");
  3431. normal_deviate:print("normaldeviate");
  3432. odd_op:print("odd");
  3433. known_op:print("known");
  3434. unknown_op:print("unknown");
  3435. not_op:print("not");
  3436. decimal:print("decimal");
  3437. reverse:print("reverse");
  3438. make_path_op:print("makepath");
  3439. make_pen_op:print("makepen");
  3440. total_weight_op:print("totalweight");
  3441. oct_op:print("oct");
  3442. hex_op:print("hex");
  3443. ASCII_op:print("ASCII");
  3444. char_op:print("char");
  3445. length_op:print("length");
  3446. turning_op:print("turningnumber");
  3447. x_part:print("xpart");
  3448. y_part:print("ypart");
  3449. xx_part:print("xxpart");
  3450. xy_part:print("xypart");
  3451. yx_part:print("yxpart");
  3452. yy_part:print("yypart");
  3453. sqrt_op:print("sqrt");
  3454. m_exp_op:print("mexp");
  3455. m_log_op:print("mlog");
  3456. sin_d_op:print("sind");
  3457. cos_d_op:print("cosd");
  3458. floor_op:print("floor");
  3459. uniform_deviate:print("uniformdeviate");
  3460. char_exists_op:print("charexists");
  3461. angle_op:print("angle");
  3462. cycle_op:print("cycle");
  3463. plus:print_char("+");
  3464. minus:print_char("-");
  3465. times:print_char("*");
  3466. over:print_char("/");
  3467. pythag_add:print("++");
  3468. pythag_sub:print("+-+");
  3469. or_op:print("or");
  3470. and_op:print("and");
  3471. less_than:print_char("<");
  3472. less_or_equal:print("<=");
  3473. greater_than:print_char(">");
  3474. greater_or_equal:print(">=");
  3475. equal_to:print_char("=");
  3476. unequal_to:print("<>");
  3477. concatenate:print("&");
  3478. rotated_by:print("rotated");
  3479. slanted_by:print("slanted");
  3480. scaled_by:print("scaled");
  3481. shifted_by:print("shifted");
  3482. transformed_by:print("transformed");
  3483. x_scaled:print("xscaled");
  3484. y_scaled:print("yscaled");
  3485. z_scaled:print("zscaled");
  3486. intersect:print("intersectiontimes");
  3487. substring_of:print("substring");
  3488. subpath_of:print("subpath");
  3489. direction_time_of:print("directiontime");
  3490. point_of:print("point");
  3491. precontrol_of:print("precontrol");
  3492. postcontrol_of:print("postcontrol");
  3493. pen_offset_of:print("penoffset");
  3494. othercases print("..")
  3495. endcases;
  3496. @ \MF\ also has a bunch of internal parameters that a user might want to
  3497. fuss with. Every such parameter has an identifying code number, defined here.
  3498. @d tracing_titles=1 {show titles online when they appear}
  3499. @d tracing_equations=2 {show each variable when it becomes known}
  3500. @d tracing_capsules=3 {show capsules too}
  3501. @d tracing_choices=4 {show the control points chosen for paths}
  3502. @d tracing_specs=5 {show subdivision of paths into octants before digitizing}
  3503. @d tracing_pens=6 {show details of pens that are made}
  3504. @d tracing_commands=7 {show commands and operations before they are performed}
  3505. @d tracing_restores=8 {show when a variable or internal is restored}
  3506. @d tracing_macros=9 {show macros before they are expanded}
  3507. @d tracing_edges=10 {show digitized edges as they are computed}
  3508. @d tracing_output=11 {show digitized edges as they are output}
  3509. @d tracing_stats=12 {show memory usage at end of job}
  3510. @d tracing_online=13 {show long diagnostics on terminal and in the log file}
  3511. @d year=14 {the current year (e.g., 1984)}
  3512. @d month=15 {the current month (e.g, 3 $\equiv$ March)}
  3513. @d day=16 {the current day of the month}
  3514. @d time=17 {the number of minutes past midnight when this job started}
  3515. @d char_code=18 {the number of the next character to be output}
  3516. @d char_ext=19 {the extension code of the next character to be output}
  3517. @d char_wd=20 {the width of the next character to be output}
  3518. @d char_ht=21 {the height of the next character to be output}
  3519. @d char_dp=22 {the depth of the next character to be output}
  3520. @d char_ic=23 {the italic correction of the next character to be output}
  3521. @d char_dx=24 {the device's $x$ movement for the next character, in pixels}
  3522. @d char_dy=25 {the device's $y$ movement for the next character, in pixels}
  3523. @d design_size=26 {the unit of measure used for |char_wd..char_ic|, in points}
  3524. @d hppp=27 {the number of horizontal pixels per point}
  3525. @d vppp=28 {the number of vertical pixels per point}
  3526. @d x_offset=29 {horizontal displacement of shipped-out characters}
  3527. @d y_offset=30 {vertical displacement of shipped-out characters}
  3528. @d pausing=31 {positive to display lines on the terminal before they are read}
  3529. @d showstopping=32 {positive to stop after each \&{show} command}
  3530. @d fontmaking=33 {positive if font metric output is to be produced}
  3531. @d proofing=34 {positive for proof mode, negative to suppress output}
  3532. @d smoothing=35 {positive if moves are to be ``smoothed''}
  3533. @d autorounding=36 {controls path modification to ``good'' points}
  3534. @d granularity=37 {autorounding uses this pixel size}
  3535. @d fillin=38 {extra darkness of diagonal lines}
  3536. @d turning_check=39 {controls reorientation of clockwise paths}
  3537. @d warning_check=40 {controls error message when variable value is large}
  3538. @d boundary_char=41 {the right boundary character for ligatures}
  3539. @d max_given_internal=41
  3540. @<Glob...@>=
  3541. @!internal:array[1..max_internal] of scaled;
  3542.   {the values of internal quantities}
  3543. @!int_name:array[1..max_internal] of str_number;
  3544.   {their names}
  3545. @!int_ptr:max_given_internal..max_internal;
  3546.   {the maximum internal quantity defined so far}
  3547. @ @<Set init...@>=
  3548. for k:=1 to max_given_internal do internal[k]:=0;
  3549. int_ptr:=max_given_internal;
  3550. @ The symbolic names for internal quantities are put into \MF's hash table
  3551. by using a routine called |primitive|, which will be defined later. Let us
  3552. enter them now, so that we don't have to list all those names again
  3553. anywhere else.
  3554. @<Put each of \MF's primitives into the hash table@>=
  3555. primitive("tracingtitles",internal_quantity,tracing_titles);@/
  3556. @!@:tracingtitles_}{\&{tracingtitles} primitive@>
  3557. primitive("tracingequations",internal_quantity,tracing_equations);@/
  3558. @!@:tracing_equations_}{\&{tracingequations} primitive@>
  3559. primitive("tracingcapsules",internal_quantity,tracing_capsules);@/
  3560. @!@:tracing_capsules_}{\&{tracingcapsules} primitive@>
  3561. primitive("tracingchoices",internal_quantity,tracing_choices);@/
  3562. @!@:tracing_choices_}{\&{tracingchoices} primitive@>
  3563. primitive("tracingspecs",internal_quantity,tracing_specs);@/
  3564. @!@:tracing_specs_}{\&{tracingspecs} primitive@>
  3565. primitive("tracingpens",internal_quantity,tracing_pens);@/
  3566. @!@:tracing_pens_}{\&{tracingpens} primitive@>
  3567. primitive("tracingcommands",internal_quantity,tracing_commands);@/
  3568. @!@:tracing_commands_}{\&{tracingcommands} primitive@>
  3569. primitive("tracingrestores",internal_quantity,tracing_restores);@/
  3570. @!@:tracing_restores_}{\&{tracingrestores} primitive@>
  3571. primitive("tracingmacros",internal_quantity,tracing_macros);@/
  3572. @!@:tracing_macros_}{\&{tracingmacros} primitive@>
  3573. primitive("tracingedges",internal_quantity,tracing_edges);@/
  3574. @!@:tracing_edges_}{\&{tracingedges} primitive@>
  3575. primitive("tracingoutput",internal_quantity,tracing_output);@/
  3576. @!@:tracing_output_}{\&{tracingoutput} primitive@>
  3577. primitive("tracingstats",internal_quantity,tracing_stats);@/
  3578. @!@:tracing_stats_}{\&{tracingstats} primitive@>
  3579. primitive("tracingonline",internal_quantity,tracing_online);@/
  3580. @!@:tracing_online_}{\&{tracingonline} primitive@>
  3581. primitive("year",internal_quantity,year);@/
  3582. @!@:year_}{\&{year} primitive@>
  3583. primitive("month",internal_quantity,month);@/
  3584. @!@:month_}{\&{month} primitive@>
  3585. primitive("day",internal_quantity,day);@/
  3586. @!@:day_}{\&{day} primitive@>
  3587. primitive("time",internal_quantity,time);@/
  3588. @!@:time_}{\&{time} primitive@>
  3589. primitive("charcode",internal_quantity,char_code);@/
  3590. @!@:char_code_}{\&{charcode} primitive@>
  3591. primitive("charext",internal_quantity,char_ext);@/
  3592. @!@:char_ext_}{\&{charext} primitive@>
  3593. primitive("charwd",internal_quantity,char_wd);@/
  3594. @!@:char_wd_}{\&{charwd} primitive@>
  3595. primitive("charht",internal_quantity,char_ht);@/
  3596. @!@:char_ht_}{\&{charht} primitive@>
  3597. primitive("chardp",internal_quantity,char_dp);@/
  3598. @!@:char_dp_}{\&{chardp} primitive@>
  3599. primitive("charic",internal_quantity,char_ic);@/
  3600. @!@:char_ic_}{\&{charic} primitive@>
  3601. primitive("chardx",internal_quantity,char_dx);@/
  3602. @!@:char_dx_}{\&{chardx} primitive@>
  3603. primitive("chardy",internal_quantity,char_dy);@/
  3604. @!@:char_dy_}{\&{chardy} primitive@>
  3605. primitive("designsize",internal_quantity,design_size);@/
  3606. @!@:design_size_}{\&{designsize} primitive@>
  3607. primitive("hppp",internal_quantity,hppp);@/
  3608. @!@:hppp_}{\&{hppp} primitive@>
  3609. primitive("vppp",internal_quantity,vppp);@/
  3610. @!@:vppp_}{\&{vppp} primitive@>
  3611. primitive("xoffset",internal_quantity,x_offset);@/
  3612. @!@:x_offset_}{\&{xoffset} primitive@>
  3613. primitive("yoffset",internal_quantity,y_offset);@/
  3614. @!@:y_offset_}{\&{yoffset} primitive@>
  3615. primitive("pausing",internal_quantity,pausing);@/
  3616. @!@:pausing_}{\&{pausing} primitive@>
  3617. primitive("showstopping",internal_quantity,showstopping);@/
  3618. @!@:showstopping_}{\&{showstopping} primitive@>
  3619. primitive("fontmaking",internal_quantity,fontmaking);@/
  3620. @!@:fontmaking_}{\&{fontmaking} primitive@>
  3621. primitive("proofing",internal_quantity,proofing);@/
  3622. @!@:proofing_}{\&{proofing} primitive@>
  3623. primitive("smoothing",internal_quantity,smoothing);@/
  3624. @!@:smoothing_}{\&{smoothing} primitive@>
  3625. primitive("autorounding",internal_quantity,autorounding);@/
  3626. @!@:autorounding_}{\&{autorounding} primitive@>
  3627. primitive("granularity",internal_quantity,granularity);@/
  3628. @!@:granularity_}{\&{granularity} primitive@>
  3629. primitive("fillin",internal_quantity,fillin);@/
  3630. @!@:fillin_}{\&{fillin} primitive@>
  3631. primitive("turningcheck",internal_quantity,turning_check);@/
  3632. @!@:turning_check_}{\&{turningcheck} primitive@>
  3633. primitive("warningcheck",internal_quantity,warning_check);@/
  3634. @!@:warning_check_}{\&{warningcheck} primitive@>
  3635. primitive("boundarychar",internal_quantity,boundary_char);@/
  3636. @!@:boundary_char_}{\&{boundarychar} primitive@>
  3637. @ Well, we do have to list the names one more time, for use in symbolic
  3638. printouts.
  3639. @<Initialize table...@>=
  3640. int_name[tracing_titles]:="tracingtitles";
  3641. int_name[tracing_equations]:="tracingequations";
  3642. int_name[tracing_capsules]:="tracingcapsules";
  3643. int_name[tracing_choices]:="tracingchoices";
  3644. int_name[tracing_specs]:="tracingspecs";
  3645. int_name[tracing_pens]:="tracingpens";
  3646. int_name[tracing_commands]:="tracingcommands";
  3647. int_name[tracing_restores]:="tracingrestores";
  3648. int_name[tracing_macros]:="tracingmacros";
  3649. int_name[tracing_edges]:="tracingedges";
  3650. int_name[tracing_output]:="tracingoutput";
  3651. int_name[tracing_stats]:="tracingstats";
  3652. int_name[tracing_online]:="tracingonline";
  3653. int_name[year]:="year";
  3654. int_name[month]:="month";
  3655. int_name[day]:="day";
  3656. int_name[time]:="time";
  3657. int_name[char_code]:="charcode";
  3658. int_name[char_ext]:="charext";
  3659. int_name[char_wd]:="charwd";
  3660. int_name[char_ht]:="charht";
  3661. int_name[char_dp]:="chardp";
  3662. int_name[char_ic]:="charic";
  3663. int_name[char_dx]:="chardx";
  3664. int_name[char_dy]:="chardy";
  3665. int_name[design_size]:="designsize";
  3666. int_name[hppp]:="hppp";
  3667. int_name[vppp]:="vppp";
  3668. int_name[x_offset]:="xoffset";
  3669. int_name[y_offset]:="yoffset";
  3670. int_name[pausing]:="pausing";
  3671. int_name[showstopping]:="showstopping";
  3672. int_name[fontmaking]:="fontmaking";
  3673. int_name[proofing]:="proofing";
  3674. int_name[smoothing]:="smoothing";
  3675. int_name[autorounding]:="autorounding";
  3676. int_name[granularity]:="granularity";
  3677. int_name[fillin]:="fillin";
  3678. int_name[turning_check]:="turningcheck";
  3679. int_name[warning_check]:="warningcheck";
  3680. int_name[boundary_char]:="boundarychar";
  3681. @ The following procedure, which is called just before \MF\ initializes its
  3682. input and output, establishes the initial values of the date and time.
  3683. @^system dependencies@>
  3684. Since standard \PASCAL\ cannot provide such information, something special
  3685. is needed. The program here simply specifies July 4, 1776, at noon; but
  3686. users probably want a better approximation to the truth.
  3687. Note that the values are |scaled| integers. Hence \MF\ can no longer
  3688. be used after the year 32767.
  3689. @p procedure fix_date_and_time;
  3690. begin internal[time]:=12*60*unity; {minutes since midnight}
  3691. internal[day]:=4*unity; {fourth day of the month}
  3692. internal[month]:=7*unity; {seventh month of the year}
  3693. internal[year]:=1776*unity; {Anno Domini}
  3694. @ \MF\ is occasionally supposed to print diagnostic information that
  3695. goes only into the transcript file, unless |tracing_online| is positive.
  3696. Now that we have defined |tracing_online| we can define
  3697. two routines that adjust the destination of print commands:
  3698. @<Basic printing...@>=
  3699. procedure begin_diagnostic; {prepare to do some tracing}
  3700. begin old_setting:=selector;
  3701. if(internal[tracing_online]<=0)and(selector=term_and_log) then
  3702.   begin decr(selector);
  3703.   if history=spotless then history:=warning_issued;
  3704.   end;
  3705. procedure end_diagnostic(@!blank_line:boolean);
  3706.   {restore proper conditions after tracing}
  3707. begin print_nl("");
  3708. if blank_line then print_ln;
  3709. selector:=old_setting;
  3710. @ Of course we had better declare another global variable, if the previous
  3711. routines are going to work.
  3712. @<Glob...@>=
  3713. @!old_setting:0..max_selector;
  3714. @ We will occasionally use |begin_diagnostic| in connection with line-number
  3715. printing, as follows. (The parameter |s| is typically |"Path"| or
  3716. |"Cycle spec"|, etc.)
  3717. @<Basic printing...@>=
  3718. procedure print_diagnostic(@!s,@!t:str_number;@!nuline:boolean);
  3719. begin begin_diagnostic;
  3720. if nuline then print_nl(s)@+else print(s);
  3721. print(" at line "); print_int(line);
  3722. print(t); print_char(":");
  3723. @ The 256 |ASCII_code| characters are grouped into classes by means of
  3724. the |char_class| table. Individual class numbers have no semantic
  3725. or syntactic significance, except in a few instances defined here.
  3726. There's also |max_class|, which can be used as a basis for additional
  3727. class numbers in nonstandard extensions of \MF.
  3728. @d digit_class=0 {the class number of \.{0123456789}}
  3729. @d period_class=1 {the class number of `\..'}
  3730. @d space_class=2 {the class number of spaces and nonstandard characters}
  3731. @d percent_class=3 {the class number of `\.\%'}
  3732. @d string_class=4 {the class number of `\."'}
  3733. @d right_paren_class=8 {the class number of `\.)'}
  3734. @d isolated_classes==5,6,7,8 {characters that make length-one tokens only}
  3735. @d letter_class=9 {letters and the underline character}
  3736. @d left_bracket_class=17 {`\.['}
  3737. @d right_bracket_class=18 {`\.]'}
  3738. @d invalid_class=20 {bad character in the input}
  3739. @d max_class=20 {the largest class number}
  3740. @<Glob...@>=
  3741. @!char_class:array[ASCII_code] of 0..max_class; {the class numbers}
  3742. @ If changes are made to accommodate non-ASCII character sets, they should
  3743. follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}.
  3744. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  3745. @^system dependencies@>
  3746. @<Set init...@>=
  3747. for k:="0" to "9" do char_class[k]:=digit_class;
  3748. char_class["."]:=period_class;
  3749. char_class[" "]:=space_class;
  3750. char_class["%"]:=percent_class;
  3751. char_class[""""]:=string_class;@/
  3752. char_class[","]:=5;
  3753. char_class[";"]:=6;
  3754. char_class["("]:=7;
  3755. char_class[")"]:=right_paren_class;
  3756. for k:="A" to "Z" do char_class[k]:=letter_class;
  3757. for k:="a" to "z" do char_class[k]:=letter_class;
  3758. char_class["_"]:=letter_class;@/
  3759. char_class["<"]:=10;
  3760. char_class["="]:=10;
  3761. char_class[">"]:=10;
  3762. char_class[":"]:=10;
  3763. char_class["|"]:=10;@/
  3764. char_class["`"]:=11;
  3765. char_class["'"]:=11;@/
  3766. char_class["+"]:=12;
  3767. char_class["-"]:=12;@/
  3768. char_class["/"]:=13;
  3769. char_class["*"]:=13;
  3770. char_class["\"]:=13;@/
  3771. char_class["!"]:=14;
  3772. char_class["?"]:=14;@/
  3773. char_class["#"]:=15;
  3774. char_class["&"]:=15;
  3775. char_class["@@"]:=15;
  3776. char_class["$"]:=15;@/
  3777. char_class["^"]:=16;
  3778. char_class["~"]:=16;@/
  3779. char_class["["]:=left_bracket_class;
  3780. char_class["]"]:=right_bracket_class;@/
  3781. char_class["{"]:=19;
  3782. char_class["}"]:=19;@/
  3783. for k:=0 to " "-1 do char_class[k]:=invalid_class;
  3784. for k:=127 to 255 do char_class[k]:=invalid_class;
  3785. @* \[13] The hash table.
  3786. Symbolic tokens are stored and retrieved by means of a fairly standard hash
  3787. table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C
  3788. in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the
  3789. table, it is never removed.
  3790. The actual sequence of characters forming a symbolic token is
  3791. stored in the |str_pool| array together with all the other strings. An
  3792. auxiliary array |hash| consists of items with two halfword fields per
  3793. word. The first of these, called |next(p)|, points to the next identifier
  3794. belonging to the same coalesced list as the identifier corresponding to~|p|;
  3795. and the other, called |text(p)|, points to the |str_start| entry for
  3796. |p|'s identifier. If position~|p| of the hash table is empty, we have
  3797. |text(p)=0|; if position |p| is either empty or the end of a coalesced
  3798. hash list, we have |next(p)=0|.
  3799. An auxiliary pointer variable called |hash_used| is maintained in such a
  3800. way that all locations |p>=hash_used| are nonempty. The global variable
  3801. |st_count| tells how many symbolic tokens have been defined, if statistics
  3802. are being kept.
  3803. The first 256 locations of |hash| are reserved for symbols of length one.
  3804. There's a parallel array called |eqtb| that contains the current equivalent
  3805. values of each symbolic token. The entries of this array consist of
  3806. two halfwords called |eq_type| (a command code) and |equiv| (a secondary
  3807. piece of information that qualifies the |eq_type|).
  3808. @d next(#) == hash[#].lh {link for coalesced lists}
  3809. @d text(#) == hash[#].rh {string number for symbolic token name}
  3810. @d eq_type(#) == eqtb[#].lh {the current ``meaning'' of a symbolic token}
  3811. @d equiv(#) == eqtb[#].rh {parametric part of a token's meaning}
  3812. @d hash_base=257 {hashing actually starts here}
  3813. @d hash_is_full == (hash_used=hash_base) {are all positions occupied?}
  3814. @<Glob...@>=
  3815. @!hash_used:pointer; {allocation pointer for |hash|}
  3816. @!st_count:integer; {total number of known identifiers}
  3817. @ Certain entries in the hash table are ``frozen'' and not redefinable,
  3818. since they are used in error recovery.
  3819. @d hash_top==hash_base+hash_size {the first location of the frozen area}
  3820. @d frozen_inaccessible==hash_top {|hash| location to protect the frozen area}
  3821. @d frozen_repeat_loop==hash_top+1 {|hash| location of a loop-repeat token}
  3822. @d frozen_right_delimiter==hash_top+2 {|hash| location of a permanent `\.)'}
  3823. @d frozen_left_bracket==hash_top+3 {|hash| location of a permanent `\.['}
  3824. @d frozen_slash==hash_top+4 {|hash| location of a permanent `\./'}
  3825. @d frozen_colon==hash_top+5 {|hash| location of a permanent `\.:'}
  3826. @d frozen_semicolon==hash_top+6 {|hash| location of a permanent `\.;'}
  3827. @d frozen_end_for==hash_top+7 {|hash| location of a permanent \&{endfor}}
  3828. @d frozen_end_def==hash_top+8 {|hash| location of a permanent \&{enddef}}
  3829. @d frozen_fi==hash_top+9 {|hash| location of a permanent \&{fi}}
  3830. @d frozen_end_group==hash_top+10
  3831.   {|hash| location of a permanent `\.{endgroup}'}
  3832. @d frozen_bad_vardef==hash_top+11 {|hash| location of `\.{a bad variable}'}
  3833. @d frozen_undefined==hash_top+12 {|hash| location that never gets defined}
  3834. @d hash_end==hash_top+12 {the actual size of the |hash| and |eqtb| arrays}
  3835. @<Glob...@>=
  3836. @!hash: array[1..hash_end] of two_halves; {the hash table}
  3837. @!eqtb: array[1..hash_end] of two_halves; {the equivalents}
  3838. @ @<Set init...@>=
  3839. next(1):=0; text(1):=0; eq_type(1):=tag_token; equiv(1):=null;
  3840. for k:=2 to hash_end do
  3841.   begin hash[k]:=hash[1]; eqtb[k]:=eqtb[1];
  3842.   end;
  3843. @ @<Initialize table entries...@>=
  3844. hash_used:=frozen_inaccessible; {nothing is used}
  3845. st_count:=0;@/
  3846. text(frozen_bad_vardef):="a bad variable";
  3847. text(frozen_fi):="fi";
  3848. text(frozen_end_group):="endgroup";
  3849. text(frozen_end_def):="enddef";
  3850. text(frozen_end_for):="endfor";@/
  3851. text(frozen_semicolon):=";";
  3852. text(frozen_colon):=":";
  3853. text(frozen_slash):="/";
  3854. text(frozen_left_bracket):="[";
  3855. text(frozen_right_delimiter):=")";@/
  3856. text(frozen_inaccessible):=" INACCESSIBLE";@/
  3857. eq_type(frozen_right_delimiter):=right_delimiter;
  3858. @ @<Check the ``constant'' values...@>=
  3859. if hash_end+max_internal>max_halfword then bad:=21;
  3860. @ Here is the subroutine that searches the hash table for an identifier
  3861. that matches a given string of length~|l| appearing in |buffer[j..
  3862. (j+l-1)]|. If the identifier is not found, it is inserted; hence it
  3863. will always be found, and the corresponding hash table address
  3864. will be returned.
  3865. @p function id_lookup(@!j,@!l:integer):pointer; {search the hash table}
  3866. label found; {go here when you've found it}
  3867. var @!h:integer; {hash code}
  3868. @!p:pointer; {index in |hash| array}
  3869. @!k:pointer; {index in |buffer| array}
  3870. begin if l=1 then @<Treat special case of length 1 and |goto found|@>;
  3871. @<Compute the hash code |h|@>;
  3872. p:=h+hash_base; {we start searching here; note that |0<=h<hash_prime|}
  3873. loop@+  begin if text(p)>0 then if length(text(p))=l then
  3874.     if str_eq_buf(text(p),j) then goto found;
  3875.   if next(p)=0 then
  3876.     @<Insert a new symbolic token after |p|, then
  3877.       make |p| point to it and |goto found|@>;
  3878.   p:=next(p);
  3879.   end;
  3880. found: id_lookup:=p;
  3881. @ @<Treat special case of length 1...@>=
  3882. begin p:=buffer[j]+1; text(p):=p-1; goto found;
  3883. @ @<Insert a new symbolic...@>=
  3884. begin if text(p)>0 then
  3885.   begin repeat if hash_is_full then
  3886.     overflow("hash size",hash_size);
  3887. @:METAFONT capacity exceeded hash size}{\quad hash size@>
  3888.   decr(hash_used);
  3889.   until text(hash_used)=0; {search for an empty location in |hash|}
  3890.   next(p):=hash_used; p:=hash_used;
  3891.   end;
  3892. str_room(l);
  3893. for k:=j to j+l-1 do append_char(buffer[k]);
  3894. text(p):=make_string; str_ref[text(p)]:=max_str_ref;
  3895. @!stat incr(st_count);@+tats@;@/
  3896. goto found;
  3897. @ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it
  3898. should be a prime number.  The theory of hashing tells us to expect fewer
  3899. than two table probes, on the average, when the search is successful.
  3900. [See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.]
  3901. @^Vitter, Jeffrey Scott@>
  3902. @<Compute the hash code |h|@>=
  3903. h:=buffer[j];
  3904. for k:=j+1 to j+l-1 do
  3905.   begin h:=h+h+buffer[k];
  3906.   while h>=hash_prime do h:=h-hash_prime;
  3907.   end
  3908. @ @<Search |eqtb| for equivalents equal to |p|@>=
  3909. for q:=1 to hash_end do
  3910.   begin if equiv(q)=p then
  3911.     begin print_nl("EQUIV("); print_int(q); print_char(")");
  3912.     end;
  3913.   end
  3914. @ We need to put \MF's ``primitive'' symbolic tokens into the hash
  3915. table, together with their command code (which will be the |eq_type|)
  3916. and an operand (which will be the |equiv|). The |primitive| procedure
  3917. does this, in a way that no \MF\ user can. The global value |cur_sym|
  3918. contains the new |eqtb| pointer after |primitive| has acted.
  3919. @p @!init procedure primitive(@!s:str_number;@!c:halfword;@!o:halfword);
  3920. var @!k:pool_pointer; {index into |str_pool|}
  3921. @!j:small_number; {index into |buffer|}
  3922. @!l:small_number; {length of the string}
  3923. begin k:=str_start[s]; l:=str_start[s+1]-k;
  3924.   {we will move |s| into the (empty) |buffer|}
  3925. for j:=0 to l-1 do buffer[j]:=so(str_pool[k+j]);
  3926. cur_sym:=id_lookup(0,l);@/
  3927. if s>=256 then {we don't want to have the string twice}
  3928.   begin flush_string(str_ptr-1); text(cur_sym):=s;
  3929.   end;
  3930. eq_type(cur_sym):=c; equiv(cur_sym):=o;
  3931. @ Many of \MF's primitives need no |equiv|, since they are identifiable
  3932. by their |eq_type| alone. These primitives are loaded into the hash table
  3933. as follows:
  3934. @<Put each of \MF's primitives into the hash table@>=
  3935. primitive("..",path_join,0);@/
  3936. @!@:.._}{\.{..} primitive@>
  3937. primitive("[",left_bracket,0); eqtb[frozen_left_bracket]:=eqtb[cur_sym];@/
  3938. @!@:[ }{\.{[} primitive@>
  3939. primitive("]",right_bracket,0);@/
  3940. @!@:] }{\.{]} primitive@>
  3941. primitive("}",right_brace,0);@/
  3942. @!@:]]}{\.{\char`\}} primitive@>
  3943. primitive("{",left_brace,0);@/
  3944. @!@:][}{\.{\char`\{} primitive@>
  3945. primitive(":",colon,0); eqtb[frozen_colon]:=eqtb[cur_sym];@/
  3946. @!@:: }{\.{:} primitive@>
  3947. primitive("::",double_colon,0);@/
  3948. @!@::: }{\.{::} primitive@>
  3949. primitive("||:",bchar_label,0);@/
  3950. @!@:::: }{\.{\char'174\char'174:} primitive@>
  3951. primitive(":=",assignment,0);@/
  3952. @!@::=_}{\.{:=} primitive@>
  3953. primitive(",",comma,0);@/
  3954. @!@:, }{\., primitive@>
  3955. primitive(";",semicolon,0); eqtb[frozen_semicolon]:=eqtb[cur_sym];@/
  3956. @!@:; }{\.; primitive@>
  3957. primitive("\",relax,0);@/
  3958. @!@:]]\\}{\.{\char`\\} primitive@>
  3959. primitive("addto",add_to_command,0);@/
  3960. @!@:add_to_}{\&{addto} primitive@>
  3961. primitive("at",at_token,0);@/
  3962. @!@:at_}{\&{at} primitive@>
  3963. primitive("atleast",at_least,0);@/
  3964. @!@:at_least_}{\&{atleast} primitive@>
  3965. primitive("begingroup",begin_group,0); bg_loc:=cur_sym;@/
  3966. @!@:begin_group_}{\&{begingroup} primitive@>
  3967. primitive("controls",controls,0);@/
  3968. @!@:controls_}{\&{controls} primitive@>
  3969. primitive("cull",cull_command,0);@/
  3970. @!@:cull_}{\&{cull} primitive@>
  3971. primitive("curl",curl_command,0);@/
  3972. @!@:curl_}{\&{curl} primitive@>
  3973. primitive("delimiters",delimiters,0);@/
  3974. @!@:delimiters_}{\&{delimiters} primitive@>
  3975. primitive("display",display_command,0);@/
  3976. @!@:display_}{\&{display} primitive@>
  3977. primitive("endgroup",end_group,0);
  3978.  eqtb[frozen_end_group]:=eqtb[cur_sym]; eg_loc:=cur_sym;@/
  3979. @!@:endgroup_}{\&{endgroup} primitive@>
  3980. primitive("everyjob",every_job_command,0);@/
  3981. @!@:every_job_}{\&{everyjob} primitive@>
  3982. primitive("exitif",exit_test,0);@/
  3983. @!@:exit_if_}{\&{exitif} primitive@>
  3984. primitive("expandafter",expand_after,0);@/
  3985. @!@:expand_after_}{\&{expandafter} primitive@>
  3986. primitive("from",from_token,0);@/
  3987. @!@:from_}{\&{from} primitive@>
  3988. primitive("inwindow",in_window,0);@/
  3989. @!@:in_window_}{\&{inwindow} primitive@>
  3990. primitive("interim",interim_command,0);@/
  3991. @!@:interim_}{\&{interim} primitive@>
  3992. primitive("let",let_command,0);@/
  3993. @!@:let_}{\&{let} primitive@>
  3994. primitive("newinternal",new_internal,0);@/
  3995. @!@:new_internal_}{\&{newinternal} primitive@>
  3996. primitive("of",of_token,0);@/
  3997. @!@:of_}{\&{of} primitive@>
  3998. primitive("openwindow",open_window,0);@/
  3999. @!@:open_window_}{\&{openwindow} primitive@>
  4000. primitive("randomseed",random_seed,0);@/
  4001. @!@:random_seed_}{\&{randomseed} primitive@>
  4002. primitive("save",save_command,0);@/
  4003. @!@:save_}{\&{save} primitive@>
  4004. primitive("scantokens",scan_tokens,0);@/
  4005. @!@:scan_tokens_}{\&{scantokens} primitive@>
  4006. primitive("shipout",ship_out_command,0);@/
  4007. @!@:ship_out_}{\&{shipout} primitive@>
  4008. primitive("skipto",skip_to,0);@/
  4009. @!@:skip_to_}{\&{skipto} primitive@>
  4010. primitive("step",step_token,0);@/
  4011. @!@:step_}{\&{step} primitive@>
  4012. primitive("str",str_op,0);@/
  4013. @!@:str_}{\&{str} primitive@>
  4014. primitive("tension",tension,0);@/
  4015. @!@:tension_}{\&{tension} primitive@>
  4016. primitive("to",to_token,0);@/
  4017. @!@:to_}{\&{to} primitive@>
  4018. primitive("until",until_token,0);@/
  4019. @!@:until_}{\&{until} primitive@>
  4020. @ Each primitive has a corresponding inverse, so that it is possible to
  4021. display the cryptic numeric contents of |eqtb| in symbolic form.
  4022. Every call of |primitive| in this program is therefore accompanied by some
  4023. straightforward code that forms part of the |print_cmd_mod| routine
  4024. explained below.
  4025. @<Cases of |print_cmd_mod| for symbolic printing of primitives@>=
  4026. add_to_command:print("addto");
  4027. assignment:print(":=");
  4028. at_least:print("atleast");
  4029. at_token:print("at");
  4030. bchar_label:print("||:");
  4031. begin_group:print("begingroup");
  4032. colon:print(":");
  4033. comma:print(",");
  4034. controls:print("controls");
  4035. cull_command:print("cull");
  4036. curl_command:print("curl");
  4037. delimiters:print("delimiters");
  4038. display_command:print("display");
  4039. double_colon:print("::");
  4040. end_group:print("endgroup");
  4041. every_job_command:print("everyjob");
  4042. exit_test:print("exitif");
  4043. expand_after:print("expandafter");
  4044. from_token:print("from");
  4045. in_window:print("inwindow");
  4046. interim_command:print("interim");
  4047. left_brace:print("{");
  4048. left_bracket:print("[");
  4049. let_command:print("let");
  4050. new_internal:print("newinternal");
  4051. of_token:print("of");
  4052. open_window:print("openwindow");
  4053. path_join:print("..");
  4054. random_seed:print("randomseed");
  4055. relax:print_char("\");
  4056. right_brace:print("}");
  4057. right_bracket:print("]");
  4058. save_command:print("save");
  4059. scan_tokens:print("scantokens");
  4060. semicolon:print(";");
  4061. ship_out_command:print("shipout");
  4062. skip_to:print("skipto");
  4063. step_token:print("step");
  4064. str_op:print("str");
  4065. tension:print("tension");
  4066. to_token:print("to");
  4067. until_token:print("until");
  4068. @ We will deal with the other primitives later, at some point in the program
  4069. where their |eq_type| and |equiv| values are more meaningful.  For example,
  4070. the primitives for macro definitions will be loaded when we consider the
  4071. routines that define macros.
  4072. It is easy to find where each particular
  4073. primitive was treated by looking in the index at the end; for example, the
  4074. section where |"def"| entered |eqtb| is listed under `\&{def} primitive'.
  4075. @* \[14] Token lists.
  4076. A \MF\ token is either symbolic or numeric or a string, or it denotes
  4077. a macro parameter or capsule; so there are five corresponding ways to encode it
  4078. @^token@>
  4079. internally: (1)~A symbolic token whose hash code is~|p|
  4080. is represented by the number |p|, in the |info| field of a single-word
  4081. node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is
  4082. represented in a two-word node of~|mem|; the |type| field is |known|,
  4083. the |name_type| field is |token|, and the |value| field holds~|v|.
  4084. The fact that this token appears in a two-word node rather than a
  4085. one-word node is, of course, clear from the node address.
  4086. (3)~A string token is also represented in a two-word node; the |type|
  4087. field is |string_type|, the |name_type| field is |token|, and the
  4088. |value| field holds the corresponding |str_number|.  (4)~Capsules have
  4089. |name_type=capsule|, and their |type| and |value| fields represent
  4090. arbitrary values (in ways to be explained later).  (5)~Macro parameters
  4091. are like symbolic tokens in that they appear in |info| fields of
  4092. one-word nodes. The $k$th parameter is represented by |expr_base+k| if it
  4093. is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or
  4094. by |text_base+k| if it is of type \&{text}.  (Here |0<=k<param_size|.)
  4095. Actual values of these parameters are kept in a separate stack, as we will
  4096. see later.  The constants |expr_base|, |suffix_base|, and |text_base| are,
  4097. of course, chosen so that there will be no confusion between symbolic
  4098. tokens and parameters of various types.
  4099. It turns out that |value(null)=0|, because |null=null_coords|;
  4100. we will make use of this coincidence later.
  4101. Incidentally, while we're speaking of coincidences, we might note that
  4102. the `\\{type}' field of a node has nothing to do with ``type'' in a
  4103. printer's sense. It's curious that the same word is used in such different ways.
  4104. @d type(#) == mem[#].hh.b0 {identifies what kind of value this is}
  4105. @d name_type(#) == mem[#].hh.b1 {a clue to the name of this value}
  4106. @d token_node_size=2 {the number of words in a large token node}
  4107. @d value_loc(#)==#+1 {the word that contains the |value| field}
  4108. @d value(#)==mem[value_loc(#)].int {the value stored in a large token node}
  4109. @d expr_base==hash_end+1 {code for the zeroth \&{expr} parameter}
  4110. @d suffix_base==expr_base+param_size {code for the zeroth \&{suffix} parameter}
  4111. @d text_base==suffix_base+param_size {code for the zeroth \&{text} parameter}
  4112. @<Check the ``constant''...@>=
  4113. if text_base+param_size>max_halfword then bad:=22;
  4114. @ A numeric token is created by the following trivial routine.
  4115. @p function new_num_tok(@!v:scaled):pointer;
  4116. var @!p:pointer; {the new node}
  4117. begin p:=get_node(token_node_size); value(p):=v;
  4118. type(p):=known; name_type(p):=token; new_num_tok:=p;
  4119. @ A token list is a singly linked list of nodes in |mem|, where
  4120. each node contains a token and a link.  Here's a subroutine that gets rid
  4121. of a token list when it is no longer needed.
  4122. @p procedure@?token_recycle; forward;@t\2@>@;@/
  4123. procedure flush_token_list(@!p:pointer);
  4124. var @!q:pointer; {the node being recycled}
  4125. begin while p<>null do
  4126.   begin q:=p; p:=link(p);
  4127.   if q>=hi_mem_min then free_avail(q)
  4128.   else  begin case type(q) of
  4129.     vacuous,boolean_type,known:do_nothing;
  4130.     string_type:delete_str_ref(value(q));
  4131.     unknown_types,pen_type,path_type,future_pen,picture_type,
  4132.      pair_type,transform_type,dependent,proto_dependent,independent:
  4133.       begin g_pointer:=q; token_recycle;
  4134.       end;
  4135.     othercases confusion("token")
  4136. @:this can't happen token}{\quad token@>
  4137.     endcases;@/
  4138.     free_node(q,token_node_size);
  4139.     end;
  4140.   end;
  4141. @ The procedure |show_token_list|, which prints a symbolic form of
  4142. the token list that starts at a given node |p|, illustrates these
  4143. conventions. The token list being displayed should not begin with a reference
  4144. count. However, the procedure is intended to be fairly robust, so that if the
  4145. memory links are awry or if |p| is not really a pointer to a token list,
  4146. almost nothing catastrophic can happen.
  4147. An additional parameter |q| is also given; this parameter is either null
  4148. or it points to a node in the token list where a certain magic computation
  4149. takes place that will be explained later. (Basically, |q| is non-null when
  4150. we are printing the two-line context information at the time of an error
  4151. message; |q| marks the place corresponding to where the second line
  4152. should begin.)
  4153. The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length
  4154. of printing exceeds a given limit~|l|; the length of printing upon entry is
  4155. assumed to be a given amount called |null_tally|. (Note that
  4156. |show_token_list| sometimes uses itself recursively to print
  4157. variable names within a capsule.)
  4158. @^recursion@>
  4159. Unusual entries are printed in the form of all-caps tokens
  4160. preceded by a space, e.g., `\.{\char`\ BAD}'.
  4161. @<Declare the procedure called |show_token_list|@>=
  4162. procedure@?print_capsule; forward; @t\2@>@;@/
  4163. procedure show_token_list(@!p,@!q:integer;@!l,@!null_tally:integer);
  4164. label exit;
  4165. var @!class,@!c:small_number; {the |char_class| of previous and new tokens}
  4166. @!r,@!v:integer; {temporary registers}
  4167. begin class:=percent_class;
  4168. tally:=null_tally;
  4169. while (p<>null) and (tally<l) do
  4170.   begin if p=q then @<Do magic computation@>;
  4171.   @<Display token |p| and set |c| to its class;
  4172.     but |return| if there are problems@>;
  4173.   class:=c; p:=link(p);
  4174.   end;
  4175. if p<>null then print(" ETC.");
  4176. @.ETC@>
  4177. exit:
  4178. @ @<Display token |p| and set |c| to its class...@>=
  4179. c:=letter_class; {the default}
  4180. if (p<mem_min)or(p>mem_end) then
  4181.   begin print(" CLOBBERED"); return;
  4182. @.CLOBBERED@>
  4183.   end;
  4184. if p<hi_mem_min then @<Display two-word token@>
  4185. else  begin r:=info(p);
  4186.   if r>=expr_base then @<Display a parameter token@>
  4187.   else if r<1 then
  4188.     if r=0 then @<Display a collective subscript@>
  4189.     else print(" IMPOSSIBLE")
  4190. @.IMPOSSIBLE@>
  4191.   else  begin r:=text(r);
  4192.     if (r<0)or(r>=str_ptr) then print(" NONEXISTENT")
  4193. @.NONEXISTENT@>
  4194.     else @<Print string |r| as a symbolic token
  4195.       and set |c| to its class@>;
  4196.     end;
  4197.   end
  4198. @ @<Display two-word token@>=
  4199. if name_type(p)=token then
  4200.   if type(p)=known then @<Display a numeric token@>
  4201.   else if type(p)<>string_type then print(" BAD")
  4202. @.BAD@>
  4203.   else  begin print_char(""""); slow_print(value(p)); print_char("""");
  4204.     c:=string_class;
  4205.     end
  4206. else if (name_type(p)<>capsule)or(type(p)<vacuous)or(type(p)>independent) then
  4207.   print(" BAD")
  4208. else  begin g_pointer:=p; print_capsule; c:=right_paren_class;
  4209.   end
  4210. @ @<Display a numeric token@>=
  4211. begin if class=digit_class then print_char(" ");
  4212. v:=value(p);
  4213. if v<0 then
  4214.   begin if class=left_bracket_class then print_char(" ");
  4215.   print_char("["); print_scaled(v); print_char("]");
  4216.   c:=right_bracket_class;
  4217.   end
  4218. else  begin print_scaled(v); c:=digit_class;
  4219.   end;
  4220. @ Strictly speaking, a genuine token will never have |info(p)=0|.
  4221. But we will see later (in the |print_variable_name| routine) that
  4222. it is convenient to let |info(p)=0| stand for `\.{[]}'.
  4223. @<Display a collective subscript@>=
  4224. begin if class=left_bracket_class then print_char(" ");
  4225. print("[]"); c:=right_bracket_class;
  4226. @ @<Display a parameter token@>=
  4227. begin if r<suffix_base then
  4228.   begin print("(EXPR"); r:=r-(expr_base);
  4229. @.EXPR@>
  4230.   end
  4231. else if r<text_base then
  4232.   begin print("(SUFFIX"); r:=r-(suffix_base);
  4233. @.SUFFIX@>
  4234.   end
  4235. else  begin print("(TEXT"); r:=r-(text_base);
  4236. @.TEXT@>
  4237.   end;
  4238. print_int(r); print_char(")"); c:=right_paren_class;
  4239. @ @<Print string |r| as a symbolic token...@>=
  4240. begin c:=char_class[so(str_pool[str_start[r]])];
  4241. if c=class then
  4242.   case c of
  4243.   letter_class:print_char(".");
  4244.   isolated_classes:do_nothing;
  4245.   othercases print_char(" ")
  4246.   endcases;
  4247. slow_print(r);
  4248. @ The following procedures have been declared |forward| with no parameters,
  4249. because the author dislikes \PASCAL's convention about |forward| procedures
  4250. with parameters. It was necessary to do something, because |show_token_list|
  4251. is recursive (although the recursion is limited to one level), and because
  4252. |flush_token_list| is syntactically (but not semantically) recursive.
  4253. @^recursion@>
  4254. @<Declare miscellaneous procedures that were declared |forward|@>=
  4255. procedure print_capsule;
  4256. begin print_char("("); print_exp(g_pointer,0); print_char(")");
  4257. procedure token_recycle;
  4258. begin recycle_value(g_pointer);
  4259. @ @<Glob...@>=
  4260. @!g_pointer:pointer; {(global) parameter to the |forward| procedures}
  4261. @ Macro definitions are kept in \MF's memory in the form of token lists
  4262. that have a few extra one-word nodes at the beginning.
  4263. The first node contains a reference count that is used to tell when the
  4264. list is no longer needed. To emphasize the fact that a reference count is
  4265. present, we shall refer to the |info| field of this special node as the
  4266. |ref_count| field.
  4267. @^reference counts@>
  4268. The next node or nodes after the reference count serve to describe the
  4269. formal parameters. They either contain a code word that specifies all
  4270. of the parameters, or they contain zero or more parameter tokens followed
  4271. by the code `|general_macro|'.
  4272. @d ref_count==info {reference count preceding a macro definition or pen header}
  4273. @d add_mac_ref(#)==incr(ref_count(#)) {make a new reference to a macro list}
  4274. @d general_macro=0 {preface to a macro defined with a parameter list}
  4275. @d primary_macro=1 {preface to a macro with a \&{primary} parameter}
  4276. @d secondary_macro=2 {preface to a macro with a \&{secondary} parameter}
  4277. @d tertiary_macro=3 {preface to a macro with a \&{tertiary} parameter}
  4278. @d expr_macro=4 {preface to a macro with an undelimited \&{expr} parameter}
  4279. @d of_macro=5 {preface to a macro with
  4280.   undelimited `\&{expr} |x| \&{of}~|y|' parameters}
  4281. @d suffix_macro=6 {preface to a macro with an undelimited \&{suffix} parameter}
  4282. @d text_macro=7 {preface to a macro with an undelimited \&{text} parameter}
  4283. @p procedure delete_mac_ref(@!p:pointer);
  4284.   {|p| points to the reference count of a macro list that is
  4285.     losing one reference}
  4286. begin if ref_count(p)=null then flush_token_list(p)
  4287. else decr(ref_count(p));
  4288. @ The following subroutine displays a macro, given a pointer to its
  4289. reference count.
  4290. @p @t\4@>@<Declare the procedure called |print_cmd_mod|@>@;
  4291. procedure show_macro(@!p:pointer;@!q,@!l:integer);
  4292. label exit;
  4293. var @!r:pointer; {temporary storage}
  4294. begin p:=link(p); {bypass the reference count}
  4295. while info(p)>text_macro do
  4296.   begin r:=link(p); link(p):=null;
  4297.   show_token_list(p,null,l,0); link(p):=r; p:=r;
  4298.   if l>0 then l:=l-tally@+else return;
  4299.   end; {control printing of `\.{ETC.}'}
  4300. @.ETC@>
  4301. tally:=0;
  4302. case info(p) of
  4303. general_macro:print("->");
  4304. @.->@>
  4305. primary_macro,secondary_macro,tertiary_macro:begin print_char("<");
  4306.   print_cmd_mod(param_type,info(p)); print(">->");
  4307.   end;
  4308. expr_macro:print("<expr>->");
  4309. of_macro:print("<expr>of<primary>->");
  4310. suffix_macro:print("<suffix>->");
  4311. text_macro:print("<text>->");
  4312. end; {there are no other cases}
  4313. show_token_list(link(p),q,l-tally,0);
  4314. exit:end;
  4315. @* \[15] Data structures for variables.
  4316. The variables of \MF\ programs can be simple, like `\.x', or they can
  4317. combine the structural properties of arrays and records, like `\.{x20a.b}'.
  4318. A \MF\ user assigns a type to a variable like \.{x20a.b} by saying, for
  4319. example, `\.{boolean} \.{x20a.b}'. It's time for us to study how such
  4320. things are represented inside of the computer.
  4321. Each variable value occupies two consecutive words, either in a two-word
  4322. node called a value node, or as a two-word subfield of a larger node.  One
  4323. of those two words is called the |value| field; it is an integer,
  4324. containing either a |scaled| numeric value or the representation of some
  4325. other type of quantity. (It might also be subdivided into halfwords, in
  4326. which case it is referred to by other names instead of |value|.) The other
  4327. word is broken into subfields called |type|, |name_type|, and |link|.  The
  4328. |type| field is a quarterword that specifies the variable's type, and
  4329. |name_type| is a quarterword from which \MF\ can reconstruct the
  4330. variable's name (sometimes by using the |link| field as well).  Thus, only
  4331. 1.25 words are actually devoted to the value itself; the other
  4332. three-quarters of a word are overhead, but they aren't wasted because they
  4333. allow \MF\ to deal with sparse arrays and to provide meaningful diagnostics.
  4334. In this section we shall be concerned only with the structural aspects of
  4335. variables, not their values. Later parts of the program will change the
  4336. |type| and |value| fields, but we shall treat those fields as black boxes
  4337. whose contents should not be touched.
  4338. However, if the |type| field is |structured|, there is no |value| field,
  4339. and the second word is broken into two pointer fields called |attr_head|
  4340. and |subscr_head|. Those fields point to additional nodes that
  4341. contain structural information, as we shall see.
  4342. @d subscr_head_loc(#) == #+1 {where |value|, |subscr_head| and |attr_head| are}
  4343. @d attr_head(#) == info(subscr_head_loc(#)) {pointer to attribute info}
  4344. @d subscr_head(#) == link(subscr_head_loc(#)) {pointer to subscript info}
  4345. @d value_node_size=2 {the number of words in a value node}
  4346. @ An attribute node is three words long. Two of these words contain |type|
  4347. and |value| fields as described above, and the third word contains
  4348. additional information:  There is an |attr_loc| field, which contains the
  4349. hash address of the token that names this attribute; and there's also a
  4350. |parent| field, which points to the value node of |structured| type at the
  4351. next higher level (i.e., at the level to which this attribute is
  4352. subsidiary).  The |name_type| in an attribute node is `|attr|'.  The
  4353. |link| field points to the next attribute with the same parent; these are
  4354. arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The
  4355. final attribute node links to the constant |end_attr|, whose |attr_loc|
  4356. field is greater than any legal hash address. The |attr_head| in the
  4357. parent points to a node whose |name_type| is |structured_root|; this
  4358. node represents the null attribute, i.e., the variable that is relevant
  4359. when no attributes are attached to the parent. The |attr_head| node is either
  4360. a value node, a subscript node, or an attribute node, depending on what
  4361. the parent would be if it were not structured; but the subscript and
  4362. attribute fields are ignored, so it effectively contains only the data of
  4363. a value node. The |link| field in this special node points to an attribute
  4364. node whose |attr_loc| field is zero; the latter node represents a collective
  4365. subscript `\.{[]}' attached to the parent, and its |link| field points to
  4366. the first non-special attribute node (or to |end_attr| if there are none).
  4367. A subscript node likewise occupies three words, with |type| and |value| fields
  4368. plus extra information; its |name_type| is |subscr|. In this case the
  4369. third word is called the |subscript| field, which is a |scaled| integer.
  4370. The |link| field points to the subscript node with the next larger
  4371. subscript, if any; otherwise the |link| points to the attribute node
  4372. for collective subscripts at this level. We have seen that the latter node
  4373. contains an upward pointer, so that the parent can be deduced.
  4374. The |name_type| in a parent-less value node is |root|, and the |link|
  4375. is the hash address of the token that names this value.
  4376. In other words, variables have a hierarchical structure that includes
  4377. enough threads running around so that the program is able to move easily
  4378. between siblings, parents, and children. An example should be helpful:
  4379. (The reader is advised to draw a picture while reading the following
  4380. description, since that will help to firm up the ideas.)
  4381. Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}'
  4382. and `\.{x20b}' have been mentioned in a user's program, where
  4383. \.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|,
  4384. and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then
  4385. |eq_type(h(x))=tag_token| and |equiv(h(x))=p|, where |p|~is a two-word value
  4386. node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=structured|,
  4387. |attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value
  4388. node and |r| to a subscript node. (Are you still following this? Use
  4389. a pencil to draw a diagram.) The lone variable `\.x' is represented by
  4390. |type(q)| and |value(q)|; furthermore
  4391. |name_type(q)=structured_root| and |link(q)=q1|, where |q1| points
  4392. to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|,
  4393. |attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|,
  4394. |type(q1)=structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|;
  4395. |qq| is a value node with |type(qq)=numeric_type| (assuming that \.{x5} is
  4396. numeric, because |qq| represents `\.{x[]}' with no further attributes),
  4397. |name_type(qq)=structured_root|, and
  4398. |link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is
  4399. an attribute node representing `\.{x[][]}', which has never yet
  4400. occurred; its |type| field is |undefined|, and its |value| field is
  4401. undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|,
  4402. |parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents
  4403. `\.{x[]b}', |type(qq2)=unknown_boolean|; also |attr_loc(qq2)=h(b)|,
  4404. |parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|.
  4405. (Maybe colored lines will help untangle your picture.)
  4406.  Node |r| is a subscript node with |type| and |value|
  4407. representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|,
  4408. and |link(r)=r1| is another subscript node. To complete the picture,
  4409. see if you can guess what |link(r1)| is; give up? It's~|q1|.
  4410. Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|,
  4411. |type(r1)=structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|,
  4412. and we finish things off with three more nodes
  4413. |qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again
  4414. with a larger sheet of paper.) The value of variable \.{x20b}
  4415. appears in node~|qqq2|, as you can well imagine.
  4416. If the example in the previous paragraph doesn't make things crystal
  4417. clear, a glance at some of the simpler subroutines below will reveal how
  4418. things work out in practice.
  4419. The only really unusual thing about these conventions is the use of
  4420. collective subscript attributes. The idea is to avoid repeating a lot of
  4421. type information when many elements of an array are identical macros
  4422. (for which distinct values need not be stored) or when they don't have
  4423. all of the possible attributes. Branches of the structure below collective
  4424. subscript attributes do not carry actual values except for macro identifiers;
  4425. branches of the structure below subscript nodes do not carry significant
  4426. information in their collective subscript attributes.
  4427. @d attr_loc_loc(#)==#+2 {where the |attr_loc| and |parent| fields are}
  4428. @d attr_loc(#)==info(attr_loc_loc(#)) {hash address of this attribute}
  4429. @d parent(#)==link(attr_loc_loc(#)) {pointer to |structured| variable}
  4430. @d subscript_loc(#)==#+2 {where the |subscript| field lives}
  4431. @d subscript(#)==mem[subscript_loc(#)].sc {subscript of this variable}
  4432. @d attr_node_size=3 {the number of words in an attribute node}
  4433. @d subscr_node_size=3 {the number of words in a subscript node}
  4434. @d collective_subscript=0 {code for the attribute `\.{[]}'}
  4435. @<Initialize table...@>=
  4436. attr_loc(end_attr):=hash_end+1; parent(end_attr):=null;
  4437. @ Variables of type \&{pair} will have values that point to four-word
  4438. nodes containing two numeric values. The first of these values has
  4439. |name_type=x_part_sector| and the second has |name_type=y_part_sector|;
  4440. the |link| in the first points back to the node whose |value| points
  4441. to this four-word node.
  4442. Variables of type \&{transform} are similar, but in this case their
  4443. |value| points to a 12-word node containing six values, identified by
  4444. |x_part_sector|, |y_part_sector|, |xx_part_sector|, |xy_part_sector|,
  4445. |yx_part_sector|, and |yy_part_sector|.
  4446. When an entire structured variable is saved, the |root| indication
  4447. is temporarily replaced by |saved_root|.
  4448. Some variables have no name; they just are used for temporary storage
  4449. while expressions are being evaluated. We call them {\sl capsules}.
  4450. @d x_part_loc(#)==# {where the \&{xpart} is found in a pair or transform node}
  4451. @d y_part_loc(#)==#+2 {where the \&{ypart} is found in a pair or transform node}
  4452. @d xx_part_loc(#)==#+4 {where the \&{xxpart} is found in a transform node}
  4453. @d xy_part_loc(#)==#+6 {where the \&{xypart} is found in a transform node}
  4454. @d yx_part_loc(#)==#+8 {where the \&{yxpart} is found in a transform node}
  4455. @d yy_part_loc(#)==#+10 {where the \&{yypart} is found in a transform node}
  4456. @d pair_node_size=4 {the number of words in a pair node}
  4457. @d transform_node_size=12 {the number of words in a transform node}
  4458. @<Glob...@>=
  4459. @!big_node_size:array[transform_type..pair_type] of small_number;
  4460. @ The |big_node_size| array simply contains two constants that \MF\
  4461. occasionally needs to know.
  4462. @<Set init...@>=
  4463. big_node_size[transform_type]:=transform_node_size;
  4464. big_node_size[pair_type]:=pair_node_size;
  4465. @ If |type(p)=pair_type| or |transform_type| and if |value(p)=null|, the
  4466. procedure call |init_big_node(p)| will allocate a pair or transform node
  4467. for~|p|.  The individual parts of such nodes are initially of type
  4468. |independent|.
  4469. @p procedure init_big_node(@!p:pointer);
  4470. var @!q:pointer; {the new node}
  4471. @!s:small_number; {its size}
  4472. begin s:=big_node_size[type(p)]; q:=get_node(s);
  4473. repeat s:=s-2; @<Make variable |q+s| newly independent@>;
  4474. name_type(q+s):=half(s)+x_part_sector; link(q+s):=null;
  4475. until s=0;
  4476. link(q):=p; value(p):=q;
  4477. @ The |id_transform| function creates a capsule for the
  4478. identity transformation.
  4479. @p function id_transform:pointer;
  4480. var @!p,@!q,@!r:pointer; {list manipulation registers}
  4481. begin p:=get_node(value_node_size); type(p):=transform_type;
  4482. name_type(p):=capsule; value(p):=null; init_big_node(p); q:=value(p);
  4483. r:=q+transform_node_size;
  4484. repeat r:=r-2;
  4485. type(r):=known; value(r):=0;
  4486. until r=q;
  4487. value(xx_part_loc(q)):=unity; value(yy_part_loc(q)):=unity;
  4488. id_transform:=p;
  4489. @ Tokens are of type |tag_token| when they first appear, but they point
  4490. to |null| until they are first used as the root of a variable.
  4491. The following subroutine establishes the root node on such grand occasions.
  4492. @p procedure new_root(@!x:pointer);
  4493. var @!p:pointer; {the new node}
  4494. begin p:=get_node(value_node_size); type(p):=undefined; name_type(p):=root;
  4495. link(p):=x; equiv(x):=p;
  4496. @ These conventions for variable representation are illustrated by the
  4497. |print_variable_name| routine, which displays the full name of a
  4498. variable given only a pointer to its two-word value packet.
  4499. @p procedure print_variable_name(@!p:pointer);
  4500. label found,exit;
  4501. var @!q:pointer; {a token list that will name the variable's suffix}
  4502. @!r:pointer; {temporary for token list creation}
  4503. begin while name_type(p)>=x_part_sector do
  4504.   @<Preface the output with a part specifier; |return| in the
  4505.     case of a capsule@>;
  4506. q:=null;
  4507. while name_type(p)>saved_root do
  4508.   @<Ascend one level, pushing a token onto list |q|
  4509.    and replacing |p| by its parent@>;
  4510. r:=get_avail; info(r):=link(p); link(r):=q;
  4511. if name_type(p)=saved_root then print("(SAVED)");
  4512. @.SAVED@>
  4513. show_token_list(r,null,el_gordo,tally); flush_token_list(r);
  4514. exit:end;
  4515. @ @<Ascend one level, pushing a token onto list |q|...@>=
  4516. begin if name_type(p)=subscr then
  4517.   begin r:=new_num_tok(subscript(p));
  4518.   repeat p:=link(p);
  4519.   until name_type(p)=attr;
  4520.   end
  4521. else if name_type(p)=structured_root then
  4522.     begin p:=link(p); goto found;
  4523.     end
  4524. else  begin if name_type(p)<>attr then confusion("var");
  4525. @:this can't happen var}{\quad var@>
  4526.   r:=get_avail; info(r):=attr_loc(p);
  4527.   end;
  4528. link(r):=q; q:=r;
  4529. found:  p:=parent(p);
  4530. @ @<Preface the output with a part specifier...@>=
  4531. begin case name_type(p) of
  4532. x_part_sector: print_char("x");
  4533. y_part_sector: print_char("y");
  4534. xx_part_sector: print("xx");
  4535. xy_part_sector: print("xy");
  4536. yx_part_sector: print("yx");
  4537. yy_part_sector: print("yy");
  4538. capsule: begin print("%CAPSULE"); print_int(p-null); return;
  4539. @.CAPSULE@>
  4540.   end;
  4541. end; {there are no other cases}
  4542. print("part "); p:=link(p-2*(name_type(p)-x_part_sector));
  4543. @ The |interesting| function returns |true| if a given variable is not
  4544. in a capsule, or if the user wants to trace capsules.
  4545. @p function interesting(@!p:pointer):boolean;
  4546. var @!t:small_number; {a |name_type|}
  4547. begin if internal[tracing_capsules]>0 then interesting:=true
  4548. else  begin t:=name_type(p);
  4549.   if t>=x_part_sector then if t<>capsule then
  4550.     t:=name_type(link(p-2*(t-x_part_sector)));
  4551.   interesting:=(t<>capsule);
  4552.   end;
  4553. @ Now here is a subroutine that converts an unstructured type into an
  4554. equivalent structured type, by inserting a |structured| node that is
  4555. capable of growing. This operation is done only when |name_type(p)=root|,
  4556. |subscr|, or |attr|.
  4557. The procedure returns a pointer to the new node that has taken node~|p|'s
  4558. place in the structure. Node~|p| itself does not move, nor are its
  4559. |value| or |type| fields changed in any way.
  4560. @p function new_structure(@!p:pointer):pointer;
  4561. var @!q,@!r:pointer; {list manipulation registers}
  4562. begin case name_type(p) of
  4563. root: begin q:=link(p); r:=get_node(value_node_size); equiv(q):=r;
  4564.   end;
  4565. subscr: @<Link a new subscript node |r| in place of node |p|@>;
  4566. attr: @<Link a new attribute node |r| in place of node |p|@>;
  4567. othercases confusion("struct")
  4568. @:this can't happen struct}{\quad struct@>
  4569. endcases;@/
  4570. link(r):=link(p); type(r):=structured; name_type(r):=name_type(p);
  4571. attr_head(r):=p; name_type(p):=structured_root;@/
  4572. q:=get_node(attr_node_size); link(p):=q; subscr_head(r):=q;
  4573. parent(q):=r; type(q):=undefined; name_type(q):=attr; link(q):=end_attr;
  4574. attr_loc(q):=collective_subscript; new_structure:=r;
  4575. @ @<Link a new subscript node |r| in place of node |p|@>=
  4576. begin q:=p;
  4577. repeat q:=link(q);
  4578. until name_type(q)=attr;
  4579. q:=parent(q); r:=subscr_head_loc(q); {|link(r)=subscr_head(q)|}
  4580. repeat q:=r; r:=link(r);
  4581. until r=p;
  4582. r:=get_node(subscr_node_size);
  4583. link(q):=r; subscript(r):=subscript(p);
  4584. @ If the attribute is |collective_subscript|, there are two pointers to
  4585. node~|p|, so we must change both of them.
  4586. @<Link a new attribute node |r| in place of node |p|@>=
  4587. begin q:=parent(p); r:=attr_head(q);
  4588. repeat q:=r; r:=link(r);
  4589. until r=p;
  4590. r:=get_node(attr_node_size); link(q):=r;@/
  4591. mem[attr_loc_loc(r)]:=mem[attr_loc_loc(p)]; {copy |attr_loc| and |parent|}
  4592. if attr_loc(p)=collective_subscript then
  4593.   begin q:=subscr_head_loc(parent(p));
  4594.   while link(q)<>p do q:=link(q);
  4595.   link(q):=r;
  4596.   end;
  4597. @ The |find_variable| routine is given a pointer~|t| to a nonempty token
  4598. list of suffixes; it returns a pointer to the corresponding two-word
  4599. value. For example, if |t| points to token \.x followed by a numeric
  4600. token containing the value~7, |find_variable| finds where the value of
  4601. \.{x7} is stored in memory. This may seem a simple task, and it
  4602. usually is, except when \.{x7} has never been referenced before.
  4603. Indeed, \.x may never have even been subscripted before; complexities
  4604. arise with respect to updating the collective subscript information.
  4605. If a macro type is detected anywhere along path~|t|, or if the first
  4606. item on |t| isn't a |tag_token|, the value |null| is returned.
  4607. Otherwise |p| will be a non-null pointer to a node such that
  4608. |undefined<type(p)<structured|.
  4609. @d abort_find==begin find_variable:=null; return;@+end
  4610. @p function find_variable(@!t:pointer):pointer;
  4611. label exit;
  4612. var @!p,@!q,@!r,@!s:pointer; {nodes in the ``value'' line}
  4613. @!pp,@!qq,@!rr,@!ss:pointer; {nodes in the ``collective'' line}
  4614. @!n:integer; {subscript or attribute}
  4615. @!save_word:memory_word; {temporary storage for a word of |mem|}
  4616. @^inner loop@>
  4617. begin p:=info(t); t:=link(t);
  4618. if eq_type(p) mod outer_tag<>tag_token then abort_find;
  4619. if equiv(p)=null then new_root(p);
  4620. p:=equiv(p); pp:=p;
  4621. while t<>null do
  4622.   begin @<Make sure that both nodes |p| and |pp| are of |structured| type@>;
  4623.   if t<hi_mem_min then
  4624.     @<Descend one level for the subscript |value(t)|@>
  4625.   else @<Descend one level for the attribute |info(t)|@>;
  4626.   t:=link(t);
  4627.   end;
  4628. if type(pp)>=structured then
  4629.   if type(pp)=structured then pp:=attr_head(pp)@+else abort_find;
  4630. if type(p)=structured then p:=attr_head(p);
  4631. if type(p)=undefined then
  4632.   begin if type(pp)=undefined then
  4633.     begin type(pp):=numeric_type; value(pp):=null;
  4634.     end;
  4635.   type(p):=type(pp); value(p):=null;
  4636.   end;
  4637. find_variable:=p;
  4638. exit:end;
  4639. @ Although |pp| and |p| begin together, they diverge when a subscript occurs;
  4640. |pp|~stays in the collective line while |p|~goes through actual subscript
  4641. values.
  4642. @<Make sure that both nodes |p| and |pp|...@>=
  4643. if type(pp)<>structured then
  4644.   begin if type(pp)>structured then abort_find;
  4645.   ss:=new_structure(pp);
  4646.   if p=pp then p:=ss;
  4647.   pp:=ss;
  4648.   end; {now |type(pp)=structured|}
  4649. if type(p)<>structured then {it cannot be |>structured|}
  4650.   p:=new_structure(p) {now |type(p)=structured|}
  4651. @ We want this part of the program to be reasonably fast, in case there are
  4652. @^inner loop@>
  4653. lots of subscripts at the same level of the data structure. Therefore
  4654. we store an ``infinite'' value in the word that appears at the end of the
  4655. subscript list, even though that word isn't part of a subscript node.
  4656. @<Descend one level for the subscript |value(t)|@>=
  4657. begin n:=value(t);
  4658. pp:=link(attr_head(pp)); {now |attr_loc(pp)=collective_subscript|}
  4659. q:=link(attr_head(p)); save_word:=mem[subscript_loc(q)];
  4660. subscript(q):=el_gordo; s:=subscr_head_loc(p); {|link(s)=subscr_head(p)|}
  4661. repeat r:=s; s:=link(s);
  4662. until n<=subscript(s);
  4663. if n=subscript(s) then p:=s
  4664. else  begin p:=get_node(subscr_node_size); link(r):=p; link(p):=s;
  4665.   subscript(p):=n; name_type(p):=subscr; type(p):=undefined;
  4666.   end;
  4667. mem[subscript_loc(q)]:=save_word;
  4668. @ @<Descend one level for the attribute |info(t)|@>=
  4669. begin n:=info(t);
  4670. ss:=attr_head(pp);
  4671. repeat rr:=ss; ss:=link(ss);
  4672. until n<=attr_loc(ss);
  4673. if n<attr_loc(ss) then
  4674.   begin qq:=get_node(attr_node_size); link(rr):=qq; link(qq):=ss;
  4675.   attr_loc(qq):=n; name_type(qq):=attr; type(qq):=undefined;
  4676.   parent(qq):=pp; ss:=qq;
  4677.   end;
  4678. if p=pp then
  4679.   begin p:=ss; pp:=ss;
  4680.   end
  4681. else  begin pp:=ss; s:=attr_head(p);
  4682.   repeat r:=s; s:=link(s);
  4683.   until n<=attr_loc(s);
  4684.   if n=attr_loc(s) then p:=s
  4685.   else  begin q:=get_node(attr_node_size); link(r):=q; link(q):=s;
  4686.     attr_loc(q):=n; name_type(q):=attr; type(q):=undefined;
  4687.     parent(q):=p; p:=q;
  4688.     end;
  4689.   end;
  4690. @ Variables lose their former values when they appear in a type declaration,
  4691. or when they are defined to be macros or \&{let} equal to something else.
  4692. A subroutine will be defined later that recycles the storage associated
  4693. with any particular |type| or |value|; our goal now is to study a higher
  4694. level process called |flush_variable|, which selectively frees parts of a
  4695. variable structure.
  4696. This routine has some complexity because of examples such as
  4697. `\hbox{\tt numeric x[]a[]b}',
  4698. which recycles all variables of the form \.{x[i]a[j]b} (and no others), while
  4699. `\hbox{\tt vardef x[]a[]=...}'
  4700. discards all variables of the form \.{x[i]a[j]} followed by an arbitrary
  4701. suffix, except for the collective node \.{x[]a[]} itself. The obvious way
  4702. to handle such examples is to use recursion; so that's what we~do.
  4703. @^recursion@>
  4704. Parameter |p| points to the root information of the variable;
  4705. parameter |t| points to a list of one-word nodes that represent
  4706. suffixes, with |info=collective_subscript| for subscripts.
  4707. @p @t\4@>@<Declare subroutines for printing expressions@>@;@/
  4708. @t\4@>@<Declare basic dependency-list subroutines@>@;
  4709. @t\4@>@<Declare the recycling subroutines@>@;
  4710. @t\4@>@<Declare the procedure called |flush_cur_exp|@>@;
  4711. @t\4@>@<Declare the procedure called |flush_below_variable|@>@;
  4712. procedure flush_variable(@!p,@!t:pointer;@!discard_suffixes:boolean);
  4713. label exit;
  4714. var @!q,@!r:pointer; {list manipulation}
  4715. @!n:halfword; {attribute to match}
  4716. begin while t<>null do
  4717.   begin if type(p)<>structured then return;
  4718.   n:=info(t); t:=link(t);
  4719.   if n=collective_subscript then
  4720.     begin r:=subscr_head_loc(p); q:=link(r); {|q=subscr_head(p)|}
  4721.     while name_type(q)=subscr do
  4722.       begin flush_variable(q,t,discard_suffixes);
  4723.       if t=null then
  4724.         if type(q)=structured then r:=q
  4725.         else  begin link(r):=link(q); free_node(q,subscr_node_size);
  4726.           end
  4727.       else r:=q;
  4728.       q:=link(r);
  4729.       end;
  4730.     end;
  4731.   p:=attr_head(p);
  4732.   repeat r:=p; p:=link(p);
  4733.   until attr_loc(p)>=n;
  4734.   if attr_loc(p)<>n then return;
  4735.   end;
  4736. if discard_suffixes then flush_below_variable(p)
  4737. else  begin if type(p)=structured then p:=attr_head(p);
  4738.   recycle_value(p);
  4739.   end;
  4740. exit:end;
  4741. @ The next procedure is simpler; it wipes out everything but |p| itself,
  4742. which becomes undefined.
  4743. @<Declare the procedure called |flush_below_variable|@>=
  4744. procedure flush_below_variable(@!p:pointer);
  4745. var @!q,@!r:pointer; {list manipulation registers}
  4746. begin if type(p)<>structured then
  4747.   recycle_value(p) {this sets |type(p)=undefined|}
  4748. else  begin q:=subscr_head(p);
  4749.   while name_type(q)=subscr do
  4750.     begin flush_below_variable(q); r:=q; q:=link(q);
  4751.     free_node(r,subscr_node_size);
  4752.     end;
  4753.   r:=attr_head(p); q:=link(r); recycle_value(r);
  4754.   if name_type(p)<=saved_root then free_node(r,value_node_size)
  4755.   else free_node(r,subscr_node_size);
  4756.     {we assume that |subscr_node_size=attr_node_size|}
  4757.   repeat flush_below_variable(q); r:=q; q:=link(q); free_node(r,attr_node_size);
  4758.   until q=end_attr;
  4759.   type(p):=undefined;
  4760.   end;
  4761. @ Just before assigning a new value to a variable, we will recycle the
  4762. old value and make the old value undefined. The |und_type| routine
  4763. determines what type of undefined value should be given, based on
  4764. the current type before recycling.
  4765. @p function und_type(@!p:pointer):small_number;
  4766. begin case type(p) of
  4767. undefined,vacuous:und_type:=undefined;
  4768. boolean_type,unknown_boolean:und_type:=unknown_boolean;
  4769. string_type,unknown_string:und_type:=unknown_string;
  4770. pen_type,unknown_pen,future_pen:und_type:=unknown_pen;
  4771. path_type,unknown_path:und_type:=unknown_path;
  4772. picture_type,unknown_picture:und_type:=unknown_picture;
  4773. transform_type,pair_type,numeric_type:und_type:=type(p);
  4774. known,dependent,proto_dependent,independent:und_type:=numeric_type;
  4775. end; {there are no other cases}
  4776. @ The |clear_symbol| routine is used when we want to redefine the equivalent
  4777. of a symbolic token. It must remove any variable structure or macro
  4778. definition that is currently attached to that symbol. If the |saving|
  4779. parameter is true, a subsidiary structure is saved instead of destroyed.
  4780. @p procedure clear_symbol(@!p:pointer;@!saving:boolean);
  4781. var @!q:pointer; {|equiv(p)|}
  4782. begin q:=equiv(p);
  4783. case eq_type(p) mod outer_tag of
  4784. defined_macro,secondary_primary_macro,tertiary_secondary_macro,
  4785.  expression_tertiary_macro: if not saving then delete_mac_ref(q);
  4786. tag_token:if q<>null then
  4787.   if saving then name_type(q):=saved_root
  4788.   else  begin flush_below_variable(q); free_node(q,value_node_size);
  4789.     end;
  4790. othercases do_nothing
  4791. endcases;@/
  4792. eqtb[p]:=eqtb[frozen_undefined];
  4793. @* \[16] Saving and restoring equivalents.
  4794. The nested structure provided by \&{begingroup} and \&{endgroup}
  4795. allows |eqtb| entries to be saved and restored, so that temporary changes
  4796. can be made without difficulty.  When the user requests a current value to
  4797. be saved, \MF\ puts that value into its ``save stack.'' An appearance of
  4798. \&{endgroup} ultimately causes the old values to be removed from the save
  4799. stack and put back in their former places.
  4800. The save stack is a linked list containing three kinds of entries,
  4801. distinguished by their |info| fields. If |p| points to a saved item,
  4802. \smallskip\hang
  4803. |info(p)=0| stands for a group boundary; each \&{begingroup} contributes
  4804. such an item to the save stack and each \&{endgroup} cuts back the stack
  4805. until the most recent such entry has been removed.
  4806. \smallskip\hang
  4807. |info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former
  4808. contents of |eqtb[q]|. Such save stack entries are generated by \&{save}
  4809. commands or suitable \&{interim} commands.
  4810. \smallskip\hang
  4811. |info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled|
  4812. integer to be restored to internal parameter number~|q|. Such entries
  4813. are generated by \&{interim} commands.
  4814. \smallskip\noindent
  4815. The global variable |save_ptr| points to the top item on the save stack.
  4816. @d save_node_size=2 {number of words per non-boundary save-stack node}
  4817. @d saved_equiv(#)==mem[#+1].hh {where an |eqtb| entry gets saved}
  4818. @d save_boundary_item(#)==begin #:=get_avail; info(#):=0;
  4819.   link(#):=save_ptr; save_ptr:=#;
  4820.   end
  4821. @<Glob...@>=@!save_ptr:pointer; {the most recently saved item}
  4822. @ @<Set init...@>=save_ptr:=null;
  4823. @ The |save_variable| routine is given a hash address |q|; it salts this
  4824. address in the save stack, together with its current equivalent,
  4825. then makes token~|q| behave as though it were brand new.
  4826. Nothing is stacked when |save_ptr=null|, however; there's no way to remove
  4827. things from the stack when the program is not inside a group, so there's
  4828. no point in wasting the space.
  4829. @p procedure save_variable(@!q:pointer);
  4830. var @!p:pointer; {temporary register}
  4831. begin if save_ptr<>null then
  4832.   begin p:=get_node(save_node_size); info(p):=q; link(p):=save_ptr;
  4833.   saved_equiv(p):=eqtb[q]; save_ptr:=p;
  4834.   end;
  4835. clear_symbol(q,(save_ptr<>null));
  4836. @ Similarly, |save_internal| is given the location |q| of an internal
  4837. quantity like |tracing_pens|. It creates a save stack entry of the
  4838. third kind.
  4839. @p procedure save_internal(@!q:halfword);
  4840. var @!p:pointer; {new item for the save stack}
  4841. begin if save_ptr<>null then
  4842.   begin p:=get_node(save_node_size); info(p):=hash_end+q;
  4843.   link(p):=save_ptr; value(p):=internal[q]; save_ptr:=p;
  4844.   end;
  4845. @ At the end of a group, the |unsave| routine restores all of the saved
  4846. equivalents in reverse order. This routine will be called only when there
  4847. is at least one boundary item on the save stack.
  4848. @p procedure unsave;
  4849. var @!q:pointer; {index to saved item}
  4850. @!p:pointer; {temporary register}
  4851. begin while info(save_ptr)<>0 do
  4852.   begin q:=info(save_ptr);
  4853.   if q>hash_end then
  4854.     begin if internal[tracing_restores]>0 then
  4855.       begin begin_diagnostic; print_nl("{restoring ");
  4856.       slow_print(int_name[q-(hash_end)]); print_char("=");
  4857.       print_scaled(value(save_ptr)); print_char("}");
  4858.       end_diagnostic(false);
  4859.       end;
  4860.     internal[q-(hash_end)]:=value(save_ptr);
  4861.     end
  4862.   else  begin if internal[tracing_restores]>0 then
  4863.       begin begin_diagnostic; print_nl("{restoring ");
  4864.       slow_print(text(q)); print_char("}");
  4865.       end_diagnostic(false);
  4866.       end;
  4867.     clear_symbol(q,false);
  4868.     eqtb[q]:=saved_equiv(save_ptr);
  4869.     if eq_type(q) mod outer_tag=tag_token then
  4870.       begin p:=equiv(q);
  4871.       if p<>null then name_type(p):=root;
  4872.       end;
  4873.     end;
  4874.   p:=link(save_ptr); free_node(save_ptr,save_node_size); save_ptr:=p;
  4875.   end;
  4876. p:=link(save_ptr); free_avail(save_ptr); save_ptr:=p;
  4877. @* \[17] Data structures for paths.
  4878. When a \MF\ user specifies a path, \MF\ will create a list of knots
  4879. and control points for the associated cubic spline curves. If the
  4880. knots are $z_0$, $z_1$, \dots, $z_n$, there are control points
  4881. $z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots
  4882. $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula
  4883. @:Bezier}{B\'ezier, Pierre Etienne@>
  4884. $$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr
  4885. &=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$
  4886. for |0<=t<=1|.
  4887. There is a 7-word node for each knot $z_k$, containing one word of
  4888. control information and six words for the |x| and |y| coordinates
  4889. of $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears
  4890. in the |left_type| and |right_type| fields, which each occupy
  4891. a quarter of the first word in the node; they specify properties
  4892. of the curve as it enters and leaves the knot. There's also a
  4893. halfword |link| field, which points to the following knot.
  4894. If the path is a closed contour, knots 0 and |n| are identical;
  4895. i.e., the |link| in knot |n-1| points to knot~0. But if the path
  4896. is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n|
  4897. are equal to |endpoint|. In the latter case the |link| in knot~|n| points
  4898. to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used.
  4899. @d left_type(#) == mem[#].hh.b0 {characterizes the path entering this knot}
  4900. @d right_type(#) == mem[#].hh.b1 {characterizes the path leaving this knot}
  4901. @d endpoint=0 {|left_type| at path beginning and |right_type| at path end}
  4902. @d x_coord(#) == mem[#+1].sc {the |x| coordinate of this knot}
  4903. @d y_coord(#) == mem[#+2].sc {the |y| coordinate of this knot}
  4904. @d left_x(#) == mem[#+3].sc {the |x| coordinate of previous control point}
  4905. @d left_y(#) == mem[#+4].sc {the |y| coordinate of previous control point}
  4906. @d right_x(#) == mem[#+5].sc {the |x| coordinate of next control point}
  4907. @d right_y(#) == mem[#+6].sc {the |y| coordinate of next control point}
  4908. @d knot_node_size=7 {number of words in a knot node}
  4909. @ Before the B\'ezier control points have been calculated, the memory
  4910. space they will ultimately occupy is taken up by information that can be
  4911. used to compute them. There are four cases:
  4912. \yskip
  4913. \textindent{$\bullet$} If |right_type=open|, the curve should leave
  4914. the knot in the same direction it entered; \MF\ will figure out a
  4915. suitable direction.
  4916. \yskip
  4917. \textindent{$\bullet$} If |right_type=curl|, the curve should leave the
  4918. knot in a direction depending on the angle at which it enters the next
  4919. knot and on the curl parameter stored in |right_curl|.
  4920. \yskip
  4921. \textindent{$\bullet$} If |right_type=given|, the curve should leave the
  4922. knot in a nonzero direction stored as an |angle| in |right_given|.
  4923. \yskip
  4924. \textindent{$\bullet$} If |right_type=explicit|, the B\'ezier control
  4925. point for leaving this knot has already been computed; it is in the
  4926. |right_x| and |right_y| fields.
  4927. \yskip\noindent
  4928. The rules for |left_type| are similar, but they refer to the curve entering
  4929. the knot, and to \\{left} fields instead of \\{right} fields.
  4930. Non-|explicit| control points will be chosen based on ``tension'' parameters
  4931. in the |left_tension| and |right_tension| fields. The
  4932. `\&{atleast}' option is represented by negative tension values.
  4933. @!@:at_least_}{\&{atleast} primitive@>
  4934. For example, the \MF\ path specification
  4935. $$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension
  4936.   3 and 4..p},$$
  4937. where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented
  4938. by the six knots
  4939. \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}}
  4940. $$\vbox{\halign{#\hfil&&\qquad#\hfil\cr
  4941. |left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr
  4942. \noalign{\yskip}
  4943. |endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr
  4944. |open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr
  4945. |curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr
  4946. |given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr
  4947. |open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr
  4948. |explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$
  4949. Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|.
  4950. Of course, this example is more complicated than anything a normal user
  4951. would ever write.
  4952. These types must satisfy certain restrictions because of the form of \MF's
  4953. path syntax:
  4954. (i)~|open| type never appears in the same node together with |endpoint|,
  4955. |given|, or |curl|.
  4956. (ii)~The |right_type| of a node is |explicit| if and only if the
  4957. |left_type| of the following node is |explicit|.
  4958. (iii)~|endpoint| types occur only at the ends, as mentioned above.
  4959. @d left_curl==left_x {curl information when entering this knot}
  4960. @d left_given==left_x {given direction when entering this knot}
  4961. @d left_tension==left_y {tension information when entering this knot}
  4962. @d right_curl==right_x {curl information when leaving this knot}
  4963. @d right_given==right_x {given direction when leaving this knot}
  4964. @d right_tension==right_y {tension information when leaving this knot}
  4965. @d explicit=1 {|left_type| or |right_type| when control points are known}
  4966. @d given=2 {|left_type| or |right_type| when a direction is given}
  4967. @d curl=3 {|left_type| or |right_type| when a curl is desired}
  4968. @d open=4 {|left_type| or |right_type| when \MF\ should choose the direction}
  4969. @ Here is a diagnostic routine that prints a given knot list
  4970. in symbolic form. It illustrates the conventions discussed above,
  4971. and checks for anomalies that might arise while \MF\ is being debugged.
  4972. @<Declare subroutines for printing expressions@>=
  4973. procedure print_path(@!h:pointer;@!s:str_number;@!nuline:boolean);
  4974. label done,done1;
  4975. var @!p,@!q:pointer; {for list traversal}
  4976. begin print_diagnostic("Path",s,nuline); print_ln;
  4977. @.Path at line...@>
  4978. p:=h;
  4979. repeat q:=link(p);
  4980. if (p=null)or(q=null) then
  4981.   begin print_nl("???"); goto done; {this won't happen}
  4982. @.???@>
  4983.   end;
  4984. @<Print information for adjacent knots |p| and |q|@>;
  4985. p:=q;
  4986. if (p<>h)or(left_type(h)<>endpoint) then
  4987.   @<Print two dots, followed by |given| or |curl| if present@>;
  4988. until p=h;
  4989. if left_type(h)<>endpoint then print("cycle");
  4990. done:end_diagnostic(true);
  4991. @ @<Print information for adjacent knots...@>=
  4992. print_two(x_coord(p),y_coord(p));
  4993. case right_type(p) of
  4994. endpoint: begin if left_type(p)=open then print("{open?}"); {can't happen}
  4995. @.open?@>
  4996.   if (left_type(q)<>endpoint)or(q<>h) then q:=null; {force an error}
  4997.   goto done1;
  4998.   end;
  4999. explicit: @<Print control points between |p| and |q|, then |goto done1|@>;
  5000. open: @<Print information for a curve that begins |open|@>;
  5001. curl,given: @<Print information for a curve that begins |curl| or |given|@>;
  5002. othercases print("???") {can't happen}
  5003. @.???@>
  5004. endcases;@/
  5005. if left_type(q)<=explicit then print("..control?") {can't happen}
  5006. @.control?@>
  5007. else if (right_tension(p)<>unity)or(left_tension(q)<>unity) then
  5008.   @<Print tension between |p| and |q|@>;
  5009. done1:
  5010. @ Since |n_sin_cos| produces |fraction| results, which we will print as if they
  5011. were |scaled|, the magnitude of a |given| direction vector will be~4096.
  5012. @<Print two dots...@>=
  5013. begin print_nl(" ..");
  5014. if left_type(p)=given then
  5015.   begin n_sin_cos(left_given(p)); print_char("{");
  5016.   print_scaled(n_cos); print_char(",");
  5017.   print_scaled(n_sin); print_char("}");
  5018.   end
  5019. else if left_type(p)=curl then
  5020.   begin print("{curl "); print_scaled(left_curl(p)); print_char("}");
  5021.   end;
  5022. @ @<Print tension between |p| and |q|@>=
  5023. begin print("..tension ");
  5024. if right_tension(p)<0 then print("atleast");
  5025. print_scaled(abs(right_tension(p)));
  5026. if right_tension(p)<>left_tension(q) then
  5027.   begin print(" and ");
  5028.   if left_tension(q)<0 then print("atleast");
  5029.   print_scaled(abs(left_tension(q)));
  5030.   end;
  5031. @ @<Print control points between |p| and |q|, then |goto done1|@>=
  5032. begin print("..controls "); print_two(right_x(p),right_y(p)); print(" and ");
  5033. if left_type(q)<>explicit then print("??") {can't happen}
  5034. @.??@>
  5035. else print_two(left_x(q),left_y(q));
  5036. goto done1;
  5037. @ @<Print information for a curve that begins |open|@>=
  5038. if (left_type(p)<>explicit)and(left_type(p)<>open) then
  5039.   print("{open?}") {can't happen}
  5040. @.open?@>
  5041. @ A curl of 1 is shown explicitly, so that the user sees clearly that
  5042. \MF's default curl is present.
  5043. The code here uses the fact that |left_curl==left_given| and
  5044. |right_curl==right_given|.
  5045. @<Print information for a curve that begins |curl|...@>=
  5046. begin if left_type(p)=open then print("??"); {can't happen}
  5047. @.??@>
  5048. if right_type(p)=curl then
  5049.   begin print("{curl "); print_scaled(right_curl(p));
  5050.   end
  5051. else  begin n_sin_cos(right_given(p)); print_char("{");
  5052.   print_scaled(n_cos); print_char(","); print_scaled(n_sin);
  5053.   end;
  5054. print_char("}");
  5055. @ If we want to duplicate a knot node, we can say |copy_knot|:
  5056. @p function copy_knot(@!p:pointer):pointer;
  5057. var @!q:pointer; {the copy}
  5058. @!k:0..knot_node_size-1; {runs through the words of a knot node}
  5059. begin q:=get_node(knot_node_size);
  5060. for k:=0 to knot_node_size-1 do mem[q+k]:=mem[p+k];
  5061. copy_knot:=q;
  5062. @ The |copy_path| routine makes a clone of a given path.
  5063. @p function copy_path(@!p:pointer):pointer;
  5064. label exit;
  5065. var @!q,@!pp,@!qq:pointer; {for list manipulation}
  5066. begin q:=get_node(knot_node_size); {this will correspond to |p|}
  5067. qq:=q; pp:=p;
  5068. loop@+  begin left_type(qq):=left_type(pp);
  5069.   right_type(qq):=right_type(pp);@/
  5070.   x_coord(qq):=x_coord(pp); y_coord(qq):=y_coord(pp);@/
  5071.   left_x(qq):=left_x(pp); left_y(qq):=left_y(pp);@/
  5072.   right_x(qq):=right_x(pp); right_y(qq):=right_y(pp);@/
  5073.   if link(pp)=p then
  5074.     begin link(qq):=q; copy_path:=q; return;
  5075.     end;
  5076.   link(qq):=get_node(knot_node_size); qq:=link(qq); pp:=link(pp);
  5077.   end;
  5078. exit:end;
  5079. @ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure
  5080. returns a pointer to the first node of the copy, if the path is a cycle,
  5081. but to the final node of a non-cyclic copy. The global
  5082. variable |path_tail| will point to the final node of the original path;
  5083. this trick makes it easier to implement `\&{doublepath}'.
  5084. All node types are assumed to be |endpoint| or |explicit| only.
  5085. @p function htap_ypoc(@!p:pointer):pointer;
  5086. label exit;
  5087. var @!q,@!pp,@!qq,@!rr:pointer; {for list manipulation}
  5088. begin q:=get_node(knot_node_size); {this will correspond to |p|}
  5089. qq:=q; pp:=p;
  5090. loop@+  begin right_type(qq):=left_type(pp); left_type(qq):=right_type(pp);@/
  5091.   x_coord(qq):=x_coord(pp); y_coord(qq):=y_coord(pp);@/
  5092.   right_x(qq):=left_x(pp); right_y(qq):=left_y(pp);@/
  5093.   left_x(qq):=right_x(pp); left_y(qq):=right_y(pp);@/
  5094.   if link(pp)=p then
  5095.     begin link(q):=qq; path_tail:=pp; htap_ypoc:=q; return;
  5096.     end;
  5097.   rr:=get_node(knot_node_size); link(rr):=qq; qq:=rr; pp:=link(pp);
  5098.   end;
  5099. exit:end;
  5100. @ @<Glob...@>=
  5101. @!path_tail:pointer; {the node that links to the beginning of a path}
  5102. @ When a cyclic list of knot nodes is no longer needed, it can be recycled by
  5103. calling the following subroutine.
  5104. @<Declare the recycling subroutines@>=
  5105. procedure toss_knot_list(@!p:pointer);
  5106. var @!q:pointer; {the node being freed}
  5107. @!r:pointer; {the next node}
  5108. begin q:=p;
  5109. repeat r:=link(q); free_node(q,knot_node_size); q:=r;
  5110. until q=p;
  5111. @* \[18] Choosing control points.
  5112. Now we must actually delve into one of \MF's more difficult routines,
  5113. the |make_choices| procedure that chooses angles and control points for
  5114. the splines of a curve when the user has not specified them explicitly.
  5115. The parameter to |make_choices| points to a list of knots and
  5116. path information, as described above.
  5117. A path decomposes into independent segments at ``breakpoint'' knots,
  5118. which are knots whose left and right angles are both prespecified in
  5119. some way (i.e., their |left_type| and |right_type| aren't both open).
  5120. @p @t\4@>@<Declare the procedure called |solve_choices|@>@;
  5121. procedure make_choices(@!knots:pointer);
  5122. label done;
  5123. var @!h:pointer; {the first breakpoint}
  5124. @!p,@!q:pointer; {consecutive breakpoints being processed}
  5125. @<Other local variables for |make_choices|@>@;
  5126. begin check_arith; {make sure that |arith_error=false|}
  5127. if internal[tracing_choices]>0 then
  5128.   print_path(knots,", before choices",true);
  5129. @<If consecutive knots are equal, join them explicitly@>;
  5130. @<Find the first breakpoint, |h|, on the path;
  5131.   insert an artificial breakpoint if the path is an unbroken cycle@>;
  5132. p:=h;
  5133. repeat @<Fill in the control points between |p| and the next breakpoint,
  5134.   then advance |p| to that breakpoint@>;
  5135. until p=h;
  5136. if internal[tracing_choices]>0 then
  5137.   print_path(knots,", after choices",true);
  5138. if arith_error then @<Report an unexpected problem during the choice-making@>;
  5139. @ @<Report an unexpected problem during the choice...@>=
  5140. begin print_err("Some number got too big");
  5141. @.Some number got too big@>
  5142. help2("The path that I just computed is out of range.")@/
  5143.   ("So it will probably look funny. Proceed, for a laugh.");
  5144. put_get_error; arith_error:=false;
  5145. @ Two knots in a row with the same coordinates will always be joined
  5146. by an explicit ``curve'' whose control points are identical with the
  5147. knots.
  5148. @<If consecutive knots are equal, join them explicitly@>=
  5149. p:=knots;
  5150. repeat q:=link(p);
  5151. if x_coord(p)=x_coord(q) then if y_coord(p)=y_coord(q) then
  5152.  if right_type(p)>explicit then
  5153.   begin right_type(p):=explicit;
  5154.   if left_type(p)=open then
  5155.     begin left_type(p):=curl; left_curl(p):=unity;
  5156.     end;
  5157.   left_type(q):=explicit;
  5158.   if right_type(q)=open then
  5159.     begin right_type(q):=curl; right_curl(q):=unity;
  5160.     end;
  5161.   right_x(p):=x_coord(p); left_x(q):=x_coord(p);@/
  5162.   right_y(p):=y_coord(p); left_y(q):=y_coord(p);
  5163.   end;
  5164. p:=q;
  5165. until p=knots
  5166. @ If there are no breakpoints, it is necessary to compute the direction
  5167. angles around an entire cycle. In this case the |left_type| of the first
  5168. node is temporarily changed to |end_cycle|.
  5169. @d end_cycle=open+1
  5170. @<Find the first breakpoint, |h|, on the path...@>=
  5171. h:=knots;
  5172. loop@+  begin if left_type(h)<>open then goto done;
  5173.   if right_type(h)<>open then goto done;
  5174.   h:=link(h);
  5175.   if h=knots then
  5176.     begin left_type(h):=end_cycle; goto done;
  5177.     end;
  5178.   end;
  5179. done:
  5180. @ If |right_type(p)<given| and |q=link(p)|, we must have
  5181. |right_type(p)=left_type(q)=explicit| or |endpoint|.
  5182. @<Fill in the control points between |p| and the next breakpoint...@>=
  5183. q:=link(p);
  5184. if right_type(p)>=given then
  5185.   begin while (left_type(q)=open)and(right_type(q)=open) do q:=link(q);
  5186.   @<Fill in the control information between
  5187.     consecutive breakpoints |p| and |q|@>;
  5188.   end;
  5189. @ Before we can go further into the way choices are made, we need to
  5190. consider the underlying theory. The basic ideas implemented in |make_choices|
  5191. are due to John Hobby, who introduced the notion of ``mock curvature''
  5192. @^Hobby, John Douglas@>
  5193. at a knot. Angles are chosen so that they preserve mock curvature when
  5194. a knot is passed, and this has been found to produce excellent results.
  5195. It is convenient to introduce some notations that simplify the necessary
  5196. formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance
  5197. between knots |k| and |k+1|; and let
  5198. $${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$
  5199. so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left
  5200. through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$.
  5201. The control points for the spline from $z_k$ to $z\k$ will be denoted by
  5202. $$\eqalign{z_k^+&=z_k+
  5203.   \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr
  5204.  z\k^-&=z\k-
  5205.   \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$
  5206. where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the
  5207. beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the
  5208. corresponding ``offset angles.'' These angles satisfy the condition
  5209. $$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$
  5210. whenever the curve leaves an intermediate knot~|k| in the direction that
  5211. it enters.
  5212. @ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of
  5213. the curve at its beginning and ending points. This means that
  5214. $\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$,
  5215. where $f(\theta,\phi)$ is \MF's standard velocity function defined in
  5216. the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+,
  5217. z\k^-,z\k^{\phantom+};t)$
  5218. has curvature
  5219. @^curvature@>
  5220. $${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}}
  5221. \qquad{\rm and}\qquad
  5222. {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$
  5223. at |t=0| and |t=1|, respectively. The mock curvature is the linear
  5224. @^mock curvature@>
  5225. approximation to this true curvature that arises in the limit for
  5226. small $\theta_k$ and~$\phi\k$, if second-order terms are discarded.
  5227. The standard velocity function satisfies
  5228. $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$
  5229. hence the mock curvatures are respectively
  5230. $${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}}
  5231. \qquad{\rm and}\qquad
  5232. {2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$
  5233. @ The turning angles $\psi_k$ are given, and equation $(*)$ above
  5234. determines $\phi_k$ when $\theta_k$ is known, so the task of
  5235. angle selection is essentially to choose appropriate values for each
  5236. $\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables
  5237. from $(**)$, we obtain a system of linear equations of the form
  5238. $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
  5239. where
  5240. $$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
  5241. \qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}},
  5242. \qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}},
  5243. \qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$
  5244. The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$
  5245. will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and
  5246. $C_k\G{5\over4}D_k$; hence the equations are diagonally dominant;
  5247. hence they have a unique solution. Moreover, in most cases the tensions
  5248. are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the
  5249. solution numerically stable, and there is an exponential damping
  5250. effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by
  5251. a factor of~$O(2^{-j})$.
  5252. @ However, we still must consider the angles at the starting and ending
  5253. knots of a non-cyclic path. These angles might be given explicitly, or
  5254. they might be specified implicitly in terms of an amount of ``curl.''
  5255. Let's assume that angles need to be determined for a non-cyclic path
  5256. starting at $z_0$ and ending at~$z_n$. Then equations of the form
  5257. $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$
  5258. have been given for $0<k<n$, and it will be convenient to introduce
  5259. equations of the same form for $k=0$ and $k=n$, where
  5260. $$A_0=B_0=C_n=D_n=0.$$
  5261. If $\theta_0$ is supposed to have a given value $E_0$, we simply
  5262. define $C_0=0$, $D_0=0$, and $R_0=E_0$. Otherwise a curl
  5263. parameter, $\gamma_0$, has been specified at~$z_0$; this means
  5264. that the mock curvature at $z_0$ should be $\gamma_0$ times the
  5265. mock curvature at $z_1$; i.e.,
  5266. $${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}}
  5267. =\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$
  5268. This equation simplifies to
  5269. $$(\alpha_0\chi_0+3-\beta_1)\theta_0+
  5270.  \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1=
  5271.  -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$
  5272. where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0=
  5273. \chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$.
  5274. It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$,
  5275. hence the linear equations remain nonsingular.
  5276. Similar considerations apply at the right end, when the final angle $\phi_n$
  5277. may or may not need to be determined. It is convenient to let $\psi_n=0$,
  5278. hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$,
  5279. or we have
  5280. $$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+
  5281. (\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad
  5282.   \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$
  5283. When |make_choices| chooses angles, it must compute the coefficients of
  5284. these linear equations, then solve the equations. To compute the coefficients,
  5285. it is necessary to compute arctangents of the given turning angles~$\psi_k$.
  5286. When the equations are solved, the chosen directions $\theta_k$ are put
  5287. back into the form of control points by essentially computing sines and
  5288. cosines.
  5289. @ OK, we are ready to make the hard choices of |make_choices|.
  5290. Most of the work is relegated to an auxiliary procedure
  5291. called |solve_choices|, which has been introduced to keep
  5292. |make_choices| from being extremely long.
  5293. @<Fill in the control information between...@>=
  5294. @<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$;
  5295.   set $n$ to the length of the path@>;
  5296. @<Remove |open| types at the breakpoints@>;
  5297. solve_choices(p,q,n)
  5298. @ It's convenient to precompute quantities that will be needed several
  5299. times later. The values of |delta_x[k]| and |delta_y[k]| will be the
  5300. coordinates of $z\k-z_k$, and the magnitude of this vector will be
  5301. |delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$
  5302. and $z\k-z_k$ will be stored in |psi[k]|.
  5303. @<Glob...@>=
  5304. @!delta_x,@!delta_y,@!delta:array[0..path_size] of scaled; {knot differences}
  5305. @!psi:array[1..path_size] of angle; {turning angles}
  5306. @ @<Other local variables for |make_choices|@>=
  5307. @!k,@!n:0..path_size; {current and final knot numbers}
  5308. @!s,@!t:pointer; {registers for list traversal}
  5309. @!delx,@!dely:scaled; {directions where |open| meets |explicit|}
  5310. @!sine,@!cosine:fraction; {trig functions of various angles}
  5311. @ @<Calculate the turning angles...@>=
  5312. k:=0; s:=p; n:=path_size;
  5313. repeat t:=link(s);
  5314. delta_x[k]:=x_coord(t)-x_coord(s);
  5315. delta_y[k]:=y_coord(t)-y_coord(s);
  5316. delta[k]:=pyth_add(delta_x[k],delta_y[k]);
  5317. if k>0 then
  5318.   begin sine:=make_fraction(delta_y[k-1],delta[k-1]);
  5319.   cosine:=make_fraction(delta_x[k-1],delta[k-1]);
  5320.   psi[k]:=n_arg(take_fraction(delta_x[k],cosine)+
  5321.       take_fraction(delta_y[k],sine),
  5322.     take_fraction(delta_y[k],cosine)-
  5323.       take_fraction(delta_x[k],sine));
  5324.   end;
  5325. @:METAFONT capacity exceeded path size}{\quad path size@>
  5326. incr(k); s:=t;
  5327. if k=path_size then overflow("path size",path_size);
  5328. if s=q then n:=k;
  5329. until (k>=n)and(left_type(s)<>end_cycle);
  5330. if k=n then psi[n]:=0@+else psi[k]:=psi[1]
  5331. @ When we get to this point of the code, |right_type(p)| is either
  5332. |given| or |curl| or |open|. If it is |open|, we must have
  5333. |left_type(p)=end_cycle| or |left_type(p)=explicit|. In the latter
  5334. case, the |open| type is converted to |given|; however, if the
  5335. velocity coming into this knot is zero, the |open| type is
  5336. converted to a |curl|, since we don't know the incoming direction.
  5337. Similarly, |left_type(q)| is either |given| or |curl| or |open| or
  5338. |end_cycle|. The |open| possibility is reduced either to |given| or to |curl|.
  5339. @<Remove |open| types at the breakpoints@>=
  5340. if left_type(q)=open then
  5341.   begin delx:=right_x(q)-x_coord(q); dely:=right_y(q)-y_coord(q);
  5342.   if (delx=0)and(dely=0) then
  5343.     begin left_type(q):=curl; left_curl(q):=unity;
  5344.     end
  5345.   else  begin left_type(q):=given; left_given(q):=n_arg(delx,dely);
  5346.     end;
  5347.   end;
  5348. if (right_type(p)=open)and(left_type(p)=explicit) then
  5349.   begin delx:=x_coord(p)-left_x(p); dely:=y_coord(p)-left_y(p);
  5350.   if (delx=0)and(dely=0) then
  5351.     begin right_type(p):=curl; right_curl(p):=unity;
  5352.     end
  5353.   else  begin right_type(p):=given; right_given(p):=n_arg(delx,dely);
  5354.     end;
  5355.   end
  5356. @ Linear equations need to be solved whenever |n>1|; and also when |n=1|
  5357. and exactly one of the breakpoints involves a curl. The simplest case occurs
  5358. when |n=1| and there is a curl at both breakpoints; then we simply draw
  5359. a straight line.
  5360. But before coding up the simple cases, we might as well face the general case,
  5361. since we must deal with it sooner or later, and since the general case
  5362. is likely to give some insight into the way simple cases can be handled best.
  5363. When there is no cycle, the linear equations to be solved form a tri-diagonal
  5364. system, and we can apply the standard technique of Gaussian elimination
  5365. to convert that system to a sequence of equations of the form
  5366. $$\theta_0+u_0\theta_1=v_0,\quad
  5367. \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad
  5368. \theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad
  5369. \theta_n=v_n.$$
  5370. It is possible to do this diagonalization while generating the equations.
  5371. Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots,
  5372. $\theta_1$, $\theta_0$; thus, the equations will be solved.
  5373. The procedure is slightly more complex when there is a cycle, but the
  5374. basic idea will be nearly the same. In the cyclic case the right-hand
  5375. sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start
  5376. the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not
  5377. $\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate
  5378. ending routine will take account of the fact that $\theta_n=\theta_0$ and
  5379. eliminate the $w$'s from the system, after which the solution can be
  5380. obtained as before.
  5381. When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer
  5382. variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|,
  5383. and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are
  5384. of type |fraction|; the $\theta$'s and $v$'s are of type |angle|.
  5385. @<Glob...@>=
  5386. @!theta:array[0..path_size] of angle; {values of $\theta_k$}
  5387. @!uu:array[0..path_size] of fraction; {values of $u_k$}
  5388. @!vv:array[0..path_size] of angle; {values of $v_k$}
  5389. @!ww:array[0..path_size] of fraction; {values of $w_k$}
  5390. @ Our immediate problem is to get the ball rolling by setting up the
  5391. first equation or by realizing that no equations are needed, and to fit
  5392. this initialization into a framework suitable for the overall computation.
  5393. @<Declare the procedure called |solve_choices|@>=
  5394. @t\4@>@<Declare subroutines needed by |solve_choices|@>@;
  5395. procedure solve_choices(@!p,@!q:pointer;@!n:halfword);
  5396. label found,exit;
  5397. var @!k:0..path_size; {current knot number}
  5398. @!r,@!s,@!t:pointer; {registers for list traversal}
  5399. @<Other local variables for |solve_choices|@>@;
  5400. begin k:=0; s:=p;
  5401. loop@+  begin t:=link(s);
  5402.   if k=0 then @<Get the linear equations started; or |return|
  5403.     with the control points in place, if linear equations
  5404.     needn't be solved@>
  5405.   else  case left_type(s) of
  5406.     end_cycle,open:@<Set up equation to match mock curvatures
  5407.       at $z_k$; then |goto found| with $\theta_n$
  5408.       adjusted to equal $\theta_0$, if a cycle has ended@>;
  5409.     curl:@<Set up equation for a curl at $\theta_n$
  5410.       and |goto found|@>;
  5411.     given:@<Calculate the given value of $\theta_n$
  5412.       and |goto found|@>;
  5413.     end; {there are no other cases}
  5414.   r:=s; s:=t; incr(k);
  5415.   end;
  5416. found:@<Finish choosing angles and assigning control points@>;
  5417. exit:end;
  5418. @ On the first time through the loop, we have |k=0| and |r| is not yet
  5419. defined. The first linear equation, if any, will have $A_0=B_0=0$.
  5420. @<Get the linear equations started...@>=
  5421. case right_type(s) of
  5422. given: if left_type(t)=given then @<Reduce to simple case of two givens
  5423.     and |return|@>
  5424.   else @<Set up the equation for a given value of $\theta_0$@>;
  5425. curl: if left_type(t)=curl then @<Reduce to simple case of straight line
  5426.     and |return|@>
  5427.   else @<Set up the equation for a curl at $\theta_0$@>;
  5428. open: begin uu[0]:=0; vv[0]:=0; ww[0]:=fraction_one;
  5429.   end; {this begins a cycle}
  5430. end {there are no other cases}
  5431. @ The general equation that specifies equality of mock curvature at $z_k$ is
  5432. $$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$
  5433. as derived above. We want to combine this with the already-derived equation
  5434. $\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain
  5435. a new equation
  5436. $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the
  5437. equation
  5438. $$(B_k-u_{k-1}A_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k-A_kv_{k-1}
  5439.     -A_kw_{k-1}\theta_0$$
  5440. by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with
  5441. fixed-point arithmetic, avoiding the chance of overflow while retaining
  5442. suitable precision.
  5443. The calculations will be performed in several registers that
  5444. provide temporary storage for intermediate quantities.
  5445. @<Other local variables for |solve_choices|@>=
  5446. @!aa,@!bb,@!cc,@!ff,@!acc:fraction; {temporary registers}
  5447. @!dd,@!ee:scaled; {likewise, but |scaled|}
  5448. @!lt,@!rt:scaled; {tension values}
  5449. @ @<Set up equation to match mock curvatures...@>=
  5450. begin @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$,
  5451.   $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$,
  5452.   and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>;
  5453. @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>;
  5454. uu[k]:=take_fraction(ff,bb);
  5455. @<Calculate the values of $v_k$ and $w_k$@>;
  5456. if left_type(s)=end_cycle then
  5457.   @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>;
  5458. @ Since tension values are never less than 3/4, the values |aa| and
  5459. |bb| computed here are never more than 4/5.
  5460. @<Calculate the values $\\{aa}=...@>=
  5461. if abs(right_tension(r))=unity then
  5462.   begin aa:=fraction_half; dd:=2*delta[k];
  5463.   end
  5464. else  begin aa:=make_fraction(unity,3*abs(right_tension(r))-unity);
  5465.   dd:=take_fraction(delta[k],
  5466.     fraction_three-make_fraction(unity,abs(right_tension(r))));
  5467.   end;
  5468. if abs(left_tension(t))=unity then
  5469.   begin bb:=fraction_half; ee:=2*delta[k-1];
  5470.   end
  5471. else  begin bb:=make_fraction(unity,3*abs(left_tension(t))-unity);
  5472.   ee:=take_fraction(delta[k-1],
  5473.     fraction_three-make_fraction(unity,abs(left_tension(t))));
  5474.   end;
  5475. cc:=fraction_one-take_fraction(uu[k-1],aa)
  5476. @ The ratio to be calculated in this step can be written in the form
  5477. $$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot
  5478.   \\{cc}\cdot\\{dd},$$
  5479. because of the quantities just calculated. The values of |dd| and |ee|
  5480. will not be needed after this step has been performed.
  5481. @<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>=
  5482. dd:=take_fraction(dd,cc); lt:=abs(left_tension(s)); rt:=abs(right_tension(s));
  5483. if lt<>rt then {$\beta_k^{-1}\ne\alpha_k^{-1}$}
  5484.   if lt<rt then
  5485.     begin ff:=make_fraction(lt,rt);
  5486.     ff:=take_fraction(ff,ff); {$\alpha_k^2/\beta_k^2$}
  5487.     dd:=take_fraction(dd,ff);
  5488.     end
  5489.   else  begin ff:=make_fraction(rt,lt);
  5490.     ff:=take_fraction(ff,ff); {$\beta_k^2/\alpha_k^2$}
  5491.     ee:=take_fraction(ee,ff);
  5492.     end;
  5493. ff:=make_fraction(ee,ee+dd)
  5494. @ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous
  5495. equation was specified by a curl. In that case we must use a special
  5496. method of computation to prevent overflow.
  5497. Fortunately, the calculations turn out to be even simpler in this ``hard''
  5498. case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence
  5499. $-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$.
  5500. @<Calculate the values of $v_k$ and $w_k$@>=
  5501. acc:=-take_fraction(psi[k+1],uu[k]);
  5502. if right_type(r)=curl then
  5503.   begin ww[k]:=0;
  5504.   vv[k]:=acc-take_fraction(psi[1],fraction_one-ff);
  5505.   end
  5506. else  begin ff:=make_fraction(fraction_one-ff,cc); {this is
  5507.     $B_k/(C_k+B_k-u_{k-1}A_k)<5$}
  5508.   acc:=acc-take_fraction(psi[k],ff);
  5509.   ff:=take_fraction(ff,aa); {this is $A_k/(C_k+B_k-u_{k-1}A_k)$}
  5510.   vv[k]:=acc-take_fraction(vv[k-1],ff);
  5511.   if ww[k-1]=0 then ww[k]:=0
  5512.   else ww[k]:=-take_fraction(ww[k-1],ff);
  5513.   end
  5514. @ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k=
  5515. v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of
  5516. $\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$
  5517. for |0<=k<n|, so that the cyclic case can be finished up just as if there
  5518. were no cycle.
  5519. The idea in the following code is to observe that
  5520. $$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr
  5521. &=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots
  5522.   -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$
  5523. so we can solve for $\theta_n=\theta_0$.
  5524. @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>=
  5525. begin aa:=0; bb:=fraction_one; {we have |k=n|}
  5526. repeat decr(k);
  5527. if k=0 then k:=n;
  5528. aa:=vv[k]-take_fraction(aa,uu[k]);
  5529. bb:=ww[k]-take_fraction(bb,uu[k]);
  5530. until k=n; {now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$}
  5531. aa:=make_fraction(aa,fraction_one-bb);
  5532. theta[n]:=aa; vv[0]:=aa;
  5533. for k:=1 to n-1 do vv[k]:=vv[k]+take_fraction(aa,ww[k]);
  5534. goto found;
  5535. @ @d reduce_angle(#)==if abs(#)>one_eighty_deg then
  5536.   if #>0 then #:=#-three_sixty_deg@+else #:=#+three_sixty_deg
  5537. @<Calculate the given value of $\theta_n$...@>=
  5538. begin theta[n]:=left_given(s)-n_arg(delta_x[n-1],delta_y[n-1]);
  5539. reduce_angle(theta[n]);
  5540. goto found;
  5541. @ @<Set up the equation for a given value of $\theta_0$@>=
  5542. begin vv[0]:=right_given(s)-n_arg(delta_x[0],delta_y[0]);
  5543. reduce_angle(vv[0]);
  5544. uu[0]:=0; ww[0]:=0;
  5545. @ @<Set up the equation for a curl at $\theta_0$@>=
  5546. begin cc:=right_curl(s); lt:=abs(left_tension(t)); rt:=abs(right_tension(s));
  5547. if (rt=unity)and(lt=unity) then
  5548.   uu[0]:=make_fraction(cc+cc+unity,cc+two)
  5549. else uu[0]:=curl_ratio(cc,rt,lt);
  5550. vv[0]:=-take_fraction(psi[1],uu[0]); ww[0]:=0;
  5551. @ @<Set up equation for a curl at $\theta_n$...@>=
  5552. begin cc:=left_curl(s); lt:=abs(left_tension(s)); rt:=abs(right_tension(r));
  5553. if (rt=unity)and(lt=unity) then
  5554.   ff:=make_fraction(cc+cc+unity,cc+two)
  5555. else ff:=curl_ratio(cc,lt,rt);
  5556. theta[n]:=-make_fraction(take_fraction(vv[n-1],ff),
  5557.     fraction_one-take_fraction(ff,uu[n-1]));
  5558. goto found;
  5559. @ The |curl_ratio| subroutine has three arguments, which our previous notation
  5560. encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is
  5561. a somewhat tedious program to calculate
  5562. $${(3-\alpha)\alpha^2\gamma+\beta^3\over
  5563.   \alpha^3\gamma+(3-\beta)\beta^2},$$
  5564. with the result reduced to 4 if it exceeds 4. (This reduction of curl
  5565. is necessary only if the curl and tension are both large.)
  5566. The values of $\alpha$ and $\beta$ will be at most~4/3.
  5567. @<Declare subroutines needed by |solve_choices|@>=
  5568. function curl_ratio(@!gamma,@!a_tension,@!b_tension:scaled):fraction;
  5569. var @!alpha,@!beta,@!num,@!denom,@!ff:fraction; {registers}
  5570. begin alpha:=make_fraction(unity,a_tension);
  5571. beta:=make_fraction(unity,b_tension);@/
  5572. if alpha<=beta then
  5573.   begin ff:=make_fraction(alpha,beta); ff:=take_fraction(ff,ff);
  5574.   gamma:=take_fraction(gamma,ff);@/
  5575.   beta:=beta div @'10000; {convert |fraction| to |scaled|}
  5576.   denom:=take_fraction(gamma,alpha)+three-beta;
  5577.   num:=take_fraction(gamma,fraction_three-alpha)+beta;
  5578.   end
  5579. else  begin ff:=make_fraction(beta,alpha); ff:=take_fraction(ff,ff);
  5580.   beta:=take_fraction(beta,ff) div @'10000; {convert |fraction| to |scaled|}
  5581.   denom:=take_fraction(gamma,alpha)+(ff div 1365)-beta;
  5582.     {$1365\approx 2^{12}/3$}
  5583.   num:=take_fraction(gamma,fraction_three-alpha)+beta;
  5584.   end;
  5585. if num>=denom+denom+denom+denom then curl_ratio:=fraction_four
  5586. else curl_ratio:=make_fraction(num,denom);
  5587. @ We're in the home stretch now.
  5588. @<Finish choosing angles and assigning control points@>=
  5589. for k:=n-1 downto 0 do theta[k]:=vv[k]-take_fraction(theta[k+1],uu[k]);
  5590. s:=p; k:=0;
  5591. repeat t:=link(s);@/
  5592. n_sin_cos(theta[k]); st:=n_sin; ct:=n_cos;@/
  5593. n_sin_cos(-psi[k+1]-theta[k+1]); sf:=n_sin; cf:=n_cos;@/
  5594. set_controls(s,t,k);@/
  5595. incr(k); s:=t;
  5596. until k=n
  5597. @ The |set_controls| routine actually puts the control points into
  5598. a pair of consecutive nodes |p| and~|q|. Global variables are used to
  5599. record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and
  5600. $\cos\phi$ needed in this calculation.
  5601. @<Glob...@>=
  5602. @!st,@!ct,@!sf,@!cf:fraction; {sines and cosines}
  5603. @ @<Declare subroutines needed by |solve_choices|@>=
  5604. procedure set_controls(@!p,@!q:pointer;@!k:integer);
  5605. var @!rr,@!ss:fraction; {velocities, divided by thrice the tension}
  5606. @!lt,@!rt:scaled; {tensions}
  5607. @!sine:fraction; {$\sin(\theta+\phi)$}
  5608. begin lt:=abs(left_tension(q)); rt:=abs(right_tension(p));
  5609. rr:=velocity(st,ct,sf,cf,rt);
  5610. ss:=velocity(sf,cf,st,ct,lt);
  5611. if (right_tension(p)<0)or(left_tension(q)<0) then @<Decrease the velocities,
  5612.   if necessary, to stay inside the bounding triangle@>;
  5613. right_x(p):=x_coord(p)+take_fraction(
  5614.   take_fraction(delta_x[k],ct)-take_fraction(delta_y[k],st),rr);
  5615. right_y(p):=y_coord(p)+take_fraction(
  5616.   take_fraction(delta_y[k],ct)+take_fraction(delta_x[k],st),rr);
  5617. left_x(q):=x_coord(q)-take_fraction(
  5618.   take_fraction(delta_x[k],cf)+take_fraction(delta_y[k],sf),ss);
  5619. left_y(q):=y_coord(q)-take_fraction(
  5620.   take_fraction(delta_y[k],cf)-take_fraction(delta_x[k],sf),ss);
  5621. right_type(p):=explicit; left_type(q):=explicit;
  5622. @ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and
  5623. $\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$,
  5624. $\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise
  5625. there is no ``bounding triangle.''
  5626. @!@:at_least_}{\&{atleast} primitive@>
  5627. @<Decrease the velocities, if necessary...@>=
  5628. if((st>=0)and(sf>=0))or((st<=0)and(sf<=0)) then
  5629.   begin sine:=take_fraction(abs(st),cf)+take_fraction(abs(sf),ct);
  5630.   if sine>0 then
  5631.     begin sine:=take_fraction(sine,fraction_one+unity); {safety factor}
  5632.     if right_tension(p)<0 then
  5633.      if ab_vs_cd(abs(sf),fraction_one,rr,sine)<0 then
  5634.       rr:=make_fraction(abs(sf),sine);
  5635.     if left_tension(q)<0 then
  5636.      if ab_vs_cd(abs(st),fraction_one,ss,sine)<0 then
  5637.       ss:=make_fraction(abs(st),sine);
  5638.     end;
  5639.   end
  5640. @ Only the simple cases remain to be handled.
  5641. @<Reduce to simple case of two givens and |return|@>=
  5642. begin aa:=n_arg(delta_x[0],delta_y[0]);@/
  5643. n_sin_cos(right_given(p)-aa); ct:=n_cos; st:=n_sin;@/
  5644. n_sin_cos(left_given(q)-aa); cf:=n_cos; sf:=-n_sin;@/
  5645. set_controls(p,q,0); return;
  5646. @ @<Reduce to simple case of straight line and |return|@>=
  5647. begin right_type(p):=explicit; left_type(q):=explicit;
  5648. lt:=abs(left_tension(q)); rt:=abs(right_tension(p));
  5649. if rt=unity then
  5650.   begin if delta_x[0]>=0 then right_x(p):=x_coord(p)+((delta_x[0]+1) div 3)
  5651.   else right_x(p):=x_coord(p)+((delta_x[0]-1) div 3);
  5652.   if delta_y[0]>=0 then right_y(p):=y_coord(p)+((delta_y[0]+1) div 3)
  5653.   else right_y(p):=y_coord(p)+((delta_y[0]-1) div 3);
  5654.   end
  5655. else  begin ff:=make_fraction(unity,3*rt); {$\alpha/3$}
  5656.   right_x(p):=x_coord(p)+take_fraction(delta_x[0],ff);
  5657.   right_y(p):=y_coord(p)+take_fraction(delta_y[0],ff);
  5658.   end;
  5659. if lt=unity then
  5660.   begin if delta_x[0]>=0 then left_x(q):=x_coord(q)-((delta_x[0]+1) div 3)
  5661.   else left_x(q):=x_coord(q)-((delta_x[0]-1) div 3);
  5662.   if delta_y[0]>=0 then left_y(q):=y_coord(q)-((delta_y[0]+1) div 3)
  5663.   else left_y(q):=y_coord(q)-((delta_y[0]-1) div 3);
  5664.   end
  5665. else  begin ff:=make_fraction(unity,3*lt); {$\beta/3$}
  5666.   left_x(q):=x_coord(q)-take_fraction(delta_x[0],ff);
  5667.   left_y(q):=y_coord(q)-take_fraction(delta_y[0],ff);
  5668.   end;
  5669. return;
  5670. @* \[19] Generating discrete moves.
  5671. The purpose of the next part of \MF\ is to compute discrete approximations
  5672. to curves described as parametric polynomial functions $z(t)$.
  5673. We shall start with the low level first, because an efficient ``engine''
  5674. is needed to support the high-level constructions.
  5675. Most of the subroutines are based on variations of a single theme,
  5676. namely the idea of {\sl bisection}. Given a Bernshte{\u\i}n polynomial
  5677. @^Bernshte{\u\i}n, Serge{\u\i} Natanovich@>
  5678. $$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$
  5679. we can conveniently bisect its range as follows:
  5680. \smallskip
  5681. \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|.
  5682. \smallskip
  5683. \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for
  5684. |0<=k<n-j|, for |0<=j<n|.
  5685. \smallskip\noindent
  5686. $$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t)
  5687.  =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$
  5688. This formula gives us the coefficients of polynomials to use over the ranges
  5689. $0\L t\L{1\over2}$ and ${1\over2}\L t\L1$.
  5690. In our applications it will usually be possible to work indirectly with
  5691. numbers that allow us to deduce relevant properties of the polynomials
  5692. without actually computing the polynomial values. We will deal with
  5693. coefficients $Z_k=2^l(z_k-z_{k-1})$ for |1<=k<=n|, instead of
  5694. the actual numbers $z_0$, $z_1$, \dots,~$z_n$, and the value of~|l| will
  5695. increase by~1 at each bisection step. This technique reduces the
  5696. amount of calculation needed for bisection and also increases the
  5697. accuracy of evaluation (since one bit of precision is gained at each
  5698. bisection). Indeed, the bisection process now becomes one level shorter:
  5699. \smallskip
  5700. \textindent{$1'$)} Let $Z_k^{(1)}=Z_k$, for |1<=k<=n|.
  5701. \smallskip
  5702. \textindent{$2'$)} Let $Z_k^{(j+1)}={1\over2}(Z_k^{(j)}+Z\k^{(j)})$, for
  5703. |1<=k<n-j|, for |1<=j<n|.
  5704. \smallskip\noindent
  5705. The relevant coefficients $(Z'_1,\ldots,Z'_n)$ and $(Z''_1,\ldots,Z''_n)$
  5706. for the two subintervals after bisection are respectively
  5707. $(Z_1^{(1)},Z_1^{(2)},\ldots,Z_1^{(n)})$ and
  5708. $(Z_1^{(n)},Z_2^{(n-1)},\ldots,Z_n^{(1)})$.
  5709. And the values of $z_0$ appropriate for the bisected interval are $z'_0=z_0$
  5710. and $z''_0=z_0+(Z_1+Z_2+\cdots+Z_n)/2^{l+1}$.
  5711. Step $2'$ involves division by~2, which introduces computational errors
  5712. of at most $1\over2$ at each step; thus after $l$~levels of bisection the
  5713. integers $Z_k$ will differ from their true values by at most $(n-1)l/2$.
  5714. This error rate is quite acceptable, considering that we have $l$~more
  5715. bits of precision in the $Z$'s by comparison with the~$z$'s.  Note also
  5716. that the $Z$'s remain bounded; there's no danger of integer overflow, even
  5717. though we have the identity $Z_k=2^l(z_k-z_{k-1})$ for arbitrarily large~$l$.
  5718. In fact, we can show not only that the $Z$'s remain bounded, but also that
  5719. they become nearly equal, since they are control points for a polynomial
  5720. of one less degree. If $\vert Z\k-Z_k\vert\L M$ initially, it is possible
  5721. to prove that $\vert Z\k-Z_k\vert\L\lceil M/2^l\rceil$ after $l$~levels
  5722. of bisection, even in the presence of rounding errors. Here's the
  5723. proof [cf.~Lane and Riesenfeld, {\sl IEEE Trans.\ on Pattern Analysis
  5724. @^Lane, Jeffrey Michael@>
  5725. @^Riesenfeld, Richard Franklin@>
  5726. and Machine Intelligence\/ \bf PAMI-2} (1980), 35--46]: Assuming that
  5727. $\vert Z\k-Z_k\vert\L M$ before bisection, we want to prove that
  5728. $\vert Z\k-Z_k\vert\L\lceil M/2\rceil$ afterward. First we show that
  5729. $\vert Z\k^{(j)}-Z_k^{(j)}\vert\L M$ for all $j$ and~$k$, by induction
  5730. on~$j$; this follows from the fact that
  5731. $$\bigl\vert\\{half}(a+b)-\\{half}(b+c)\bigr\vert\L
  5732.  \max\bigl(\vert a-b\vert,\vert b-c\vert\bigr)$$
  5733. holds for both of the rounding rules $\\{half}(x)=\lfloor x/2\rfloor$
  5734. and $\\{half}(x)={\rm sign}(x)\lfloor\vert x/2\vert\rfloor$.
  5735. (If $\vert a-b\vert$ and $\vert b-c\vert$ are equal, then
  5736. $a+b$ and $b+c$ are both even or both odd. The rounding errors either
  5737. cancel or round the numbers toward each other; hence
  5738. $$\eqalign{\bigl\vert\\{half}(a+b)-\\{half}(b+c)\bigr\vert
  5739. &\L\textstyle\bigl\vert{1\over2}(a+b)-{1\over2}(b+c)\bigr\vert\cr
  5740. &=\textstyle\bigl\vert{1\over2}(a-b)+{1\over2}(b-c)\bigr\vert
  5741. \L\max\bigl(\vert a-b\vert,\vert b-c\vert\bigr),\cr}$$
  5742. as required. A simpler argument applies if $\vert a-b\vert$ and
  5743. $\vert b-c\vert$ are unequal.)  Now it is easy to see that
  5744. $\vert Z_1^{(j+1)}-Z_1^{(j)}\vert\L\bigl\lfloor{1\over2}
  5745. \vert Z_2^{(j)}-Z_1^{(j)}\vert+{1\over2}\bigr\rfloor
  5746. \L\bigl\lfloor{1\over2}(M+1)\bigr\rfloor=\lceil M/2\rceil$.
  5747. Another interesting fact about bisection is the identity
  5748. $$Z_1'+\cdots+Z_n'+Z_1''+\cdots+Z_n''=2(Z_1+\cdots+Z_n+E),$$
  5749. where $E$ is the sum of the rounding errors in all of the halving
  5750. operations ($\vert E\vert\L n(n-1)/4$).
  5751. @ We will later reduce the problem of digitizing a complex cubic
  5752. $z(t)=B(z_0,z_1,z_2,z_3;t)$ to the following simpler problem:
  5753. Given two real cubics
  5754. $x(t)=B(x_0,x_1,x_2,x_3;t)$
  5755. and $y(t)=B(y_0,y_1,y_2,y_3;t)$ that are monotone nondecreasing,
  5756. determine the set of integer points
  5757. $$P=\bigl\{\bigl(\lfloor x(t)\rfloor,\lfloor y(t)\rfloor\bigr)
  5758. \bigm\vert 0\L t\L 1\bigr\}.$$
  5759. Well, the problem isn't actually quite so clean as this; when the path
  5760. goes very near an integer point $(a,b)$, computational errors may
  5761. make us think that $P$ contains $(a-1,b)$ while in reality it should
  5762. contain $(a,b-1)$. Furthermore, if the path goes {\sl exactly\/}
  5763. through the integer points $(a-1,b-1)$ and
  5764. $(a,b)$, we will want $P$ to contain one
  5765. of the two points $(a-1,b)$ or $(a,b-1)$, so that $P$ can be described
  5766. entirely by ``rook moves'' upwards or to the right; no diagonal
  5767. moves from $(a-1,b-1)$ to~$(a,b)$ will be allowed.
  5768. Thus, the set $P$ we wish to compute will merely be an approximation
  5769. to the set described in the formula above. It will consist of
  5770. $\lfloor x(1)\rfloor-\lfloor x(0)\rfloor$ rightward moves and
  5771. $\lfloor y(1)\rfloor-\lfloor y(0)\rfloor$ upward moves, intermixed
  5772. in some order. Our job will be to figure out a suitable order.
  5773. The following recursive strategy suggests itself, when we recall that
  5774. $x(0)=x_0$, $x(1)=x_3$, $y(0)=y_0$, and $y(1)=y_3$:
  5775. \smallskip
  5776. If $\lfloor x_0\rfloor=\lfloor x_3\rfloor$ then take
  5777. $\lfloor y_3\rfloor-\lfloor y_0\rfloor$ steps up.
  5778. Otherwise if $\lfloor y_0\rfloor=\lfloor y_3\rfloor$ then take
  5779. $\lfloor x_3\rfloor-\lfloor x_0\rfloor$ steps to the right.
  5780. Otherwise bisect the current cubics and repeat the process on both halves.
  5781. \yskip\noindent
  5782. This intuitively appealing formulation does not quite solve the problem,
  5783. because it may never terminate. For example, it's not hard to see that
  5784. no steps will {\sl ever\/} be taken if $(x_0,x_1,x_2,x_3)=(y_0,y_1,y_2,y_3)$!
  5785. However, we can surmount this difficulty with a bit of care; so let's
  5786. proceed to flesh out the algorithm as stated, before worrying about
  5787. such details.
  5788. The bisect-and-double strategy discussed above suggests that we represent
  5789. $(x_0,x_1,x_2,x_3)$ by $(X_1,X_2,X_3)$, where $X_k=2^l(x_k-x_{k-1})$
  5790. for some~$l$. Initially $l=16$, since the $x$'s are |scaled|.
  5791. In order to deal with other aspects of the algorithm we will want to
  5792. maintain also the quantities $m=\lfloor x_3\rfloor-\lfloor x_0\rfloor$
  5793. and $R=2^l(x_0\bmod 1)$. Similarly,
  5794. $(y_0,y_1,y_2,y_3)$ will be represented by $(Y_1,Y_2,Y_3)$,
  5795. $n=\lfloor y_3\rfloor-\lfloor y_0\rfloor$,
  5796. and $S=2^l(y_0\bmod 1)$. The algorithm now takes the following form:
  5797. \smallskip
  5798. If $m=0$ then take $n$ steps up.
  5799. Otherwise if $n=0$ then take $m$ steps to the right.
  5800. Otherwise bisect the current cubics and repeat the process on both halves.
  5801. \smallskip\noindent
  5802. The bisection process for $(X_1,X_2,X_3,m,R,l)$ reduces, in essence,
  5803. to the following formulas:
  5804. $$\vbox{\halign{$#\hfil$\cr
  5805. X_2'=\\{half}(X_1+X_2),\quad
  5806. X_2''=\\{half}(X_2+X_3),\quad
  5807. X_3'=\\{half}(X_2'+X_2''),\cr
  5808. X_1'=X_1,\quad
  5809. X_1''=X_3',\quad
  5810. X_3''=X_3,\cr
  5811. R'=2R,\quad
  5812. T=X_1'+X_2'+X_3'+R',\quad
  5813. R''=T\bmod 2^{l+1},\cr
  5814. m'=\lfloor T/2^{l+1}\rfloor,\quad
  5815. m''=m-m'.\cr}}$$
  5816. @ When $m=n=1$, the computation can be speeded up because we simply
  5817. need to decide between two alternatives, (up,\thinspace right)
  5818. versus (right,\thinspace up). There appears to be no simple, direct
  5819. way to make the correct decision by looking at the values of
  5820. $(X_1,X_2,X_3,R)$ and
  5821. $(Y_1,Y_2,Y_3,S)$; but we can streamline the bisection process, and
  5822. we can use the fact that only one of the two descendants needs to
  5823. be examined after each bisection. Furthermore, we observed earlier
  5824. that after several levels of bisection the $X$'s and $Y$'s will be nearly
  5825. equal; so we will be justified in assuming that the curve is essentially a
  5826. straight line. (This, incidentally, solves the problem of infinite
  5827. recursion mentioned earlier.)
  5828. It is possible to show that
  5829. $$m=\bigl\lfloor(X_1+X_2+X_3+R+E)\,/\,2^l\bigr\rfloor,$$
  5830. where $E$ is an accumulated rounding error that is at most
  5831. $3\cdot(2^{l-16}-1)$ in absolute value. We will make sure that
  5832. the $X$'s are less than $2^{28}$; hence when $l=30$ we must
  5833. have |m<=1|. This proves that the special case $m=n=1$ is
  5834. bound to be reached by the time $l=30$. Furthermore $l=30$ is
  5835. a suitable time to make the straight line approximation,
  5836. if the recursion hasn't already died out, because the maximum
  5837. difference between $X$'s will then be $<2^{14}$; this corresponds
  5838. to an error of $<1$ with respect to the original scaling.
  5839. (Stating this another way, each bisection makes the curve two bits
  5840. closer to a straight line, hence 14 bisections are sufficient for
  5841. 28-bit accuracy.)
  5842. In the case of a straight line, the curve goes first right, then up,
  5843. if and only if $(T-2^l)(2^l-S)>(U-2^l)(2^l-R)$, where
  5844. $T=X_1+X_2+X_3+R$ and $U=Y_1+Y_2+Y_3+S$. For the actual curve
  5845. essentially runs from $(R/2^l,S/2^l)$ to $(T/2^l,U/2^l)$, and
  5846. we are testing whether or not $(1,1)$ is above the straight
  5847. line connecting these two points. (This formula assumes that $(1,1)$
  5848. is not exactly on the line.)
  5849. @ We have glossed over the problem of tie-breaking in ambiguous
  5850. cases when the cubic curve passes exactly through integer points.
  5851. \MF\ finesses this problem by assuming that coordinates
  5852. $(x,y)$ actually stand for slightly perturbed values $(x+\xi,y+\eta)$,
  5853. where $\xi$ and~$\eta$ are infinitesimals whose signs will determine
  5854. what to do when $x$ and/or~$y$ are exact integers. The quantities
  5855. $\lfloor x\rfloor$ and~$\lfloor y\rfloor$ in the formulas above
  5856. should actually read $\lfloor x+\xi\rfloor$ and $\lfloor y+\eta\rfloor$.
  5857. If $x$ is a |scaled| value, we have $\lfloor x+\xi\rfloor=\lfloor x\rfloor$
  5858. if $\xi>0$, and $\lfloor x+\xi\rfloor=\lfloor x-2^{-16}\rfloor$ if
  5859. $\xi<0$. It is convenient to represent $\xi$ by the integer |xi_corr|,
  5860. defined to be 0~if $\xi>0$ and 1~if $\xi<0$; then, for example, the
  5861. integer $\lfloor x+\xi\rfloor$ can be computed as
  5862. |floor_unscaled(x-xi_corr)|. Similarly, $\eta$ is conveniently
  5863. represented by~|eta_corr|.
  5864. In our applications the sign of $\xi-\eta$ will always be the same as
  5865. the sign of $\xi$. Therefore it turns out that the rule for straight
  5866. lines, as stated above, should be modified as follows in the case of
  5867. ties: The line goes first right, then up, if and only if
  5868. $(T-2^l)(2^l-S)+\xi>(U-2^l)(2^l-R)$. And this relation holds iff
  5869. $|ab_vs_cd|(T-2^l,2^l-S,U-2^l,2^l-R)-|xi_corr|\ge0$.
  5870. These conventions for rounding are symmetrical, in the sense that the
  5871. digitized moves obtained from $(x_0,x_1,x_2,x_3,y_0,y_1,y_2,y_3,\xi,\eta)$
  5872. will be exactly complementary to the moves that would be obtained from
  5873. $(-x_3,-x_2,-x_1,-x_0,-y_3,-y_2,-y_1,-y_0,-\xi,-\eta)$, if arithmetic
  5874. is exact. However, truncation errors in the bisection process might
  5875. upset the symmetry. We can restore much of the lost symmetry by adding
  5876. |xi_corr| or |eta_corr| when halving the data.
  5877. @ One further possibility needs to be mentioned: The algorithm
  5878. will be applied only to cubic polynomials $B(x_0,x_1,x_2,x_3;t)$ that
  5879. are nondecreasing as $t$~varies from 0 to~1; this condition turns
  5880. out to hold if and only if $x_0\L x_1$, $x_2\L x_3$, and either
  5881. $x_1\L x_2$ or $(x_1-x_2)^2\L(x_1-x_0)(x_3-x_2)$. If bisection were
  5882. carried out with perfect accuracy, these relations would remain
  5883. invariant. But rounding errors can creep in, hence the bisection
  5884. algorithm can produce non-monotonic subproblems from monotonic
  5885. initial conditions. This leads to the potential danger that $m$ or~$n$
  5886. could become negative in the algorithm described above.
  5887. For example, if we start with $(x_1-x_0,x_2-x_1,x_3-x_2)=
  5888. (X_1,X_2,X_3)=(7,-16,58)$, the corresponding polynomial is
  5889. monotonic, because $16^2<7\cdot39$. But the bisection algorithm
  5890. produces the left descendant $(7,-5,3)$, which is nonmonotonic;
  5891. its right descendant is~$(0,-1,3)$.
  5892. \def\xt{{\tilde x}}
  5893. Fortunately we can prove that such rounding errors will never cause
  5894. the algorithm to make a tragic mistake. At every stage we are working
  5895. with numbers corresponding to a cubic polynomial $B(\xt_0,
  5896. \xt_1,\xt_2,\xt_3)$ that approximates some
  5897. monotonic polynomial $B(x_0,x_1,x_2,x_3)$. The accumulated errors are
  5898. controlled so that $\vert x_k-\xt_k\vert<\epsilon=3\cdot2^{-16}$.
  5899. If bisection is done at some stage of the recursion, we have
  5900. $m=\lfloor\xt_3\rfloor-\lfloor\xt_0\rfloor>0$, and the algorithm
  5901. computes a bisection value $\bar x$ such that $m'=\lfloor\bar x\rfloor-
  5902. \lfloor\xt_0\rfloor$
  5903. and $m''=\lfloor\xt_3\rfloor-\lfloor\bar x\rfloor$. We want to prove
  5904. that neither $m'$ nor $m''$ can be negative. Since $\bar x$ is an
  5905. approximation to a value in the interval $[x_0,x_3]$, we have
  5906. $\bar x>x_0-\epsilon$ and $\bar x<x_3+\epsilon$, hence $\bar x>
  5907. \xt_0-2\epsilon$ and $\bar x<\xt_3+2\epsilon$.
  5908. If $m'$ is negative we must have $\xt_0\bmod 1<2\epsilon$;
  5909. if $m''$ is negative we must have $\xt_3\bmod 1>1-2\epsilon$.
  5910. In either case the condition $\lfloor\xt_3\rfloor-\lfloor\xt_0\rfloor>0$
  5911. implies that $\xt_3-\xt_0>1-2\epsilon$, hence $x_3-x_0>1-4\epsilon$.
  5912. But it can be shown that if $B(x_0,x_1,x_2,x_3;t)$ is a monotonic
  5913. cubic, then $B(x_0,x_1,x_2,x_3;{1\over2})$ is always between
  5914. $.14[x_0,x_3]$ and $.86[x_0,x_3]$; and it is impossible for $\bar x$
  5915. to be within~$\epsilon$ of such a number. Contradiction!
  5916. (The constant .14 is actually $(7-\sqrt{28}\,)/12$; the worst case
  5917. occurs for polynomials like $B(0,28-4\sqrt{28},14-5\sqrt{28},42;t)$.)
  5918. @ OK, now that a long theoretical preamble has justified the
  5919. bisection-and-doubling algorithm, we are ready to proceed with
  5920. its actual coding. But we still haven't discussed the
  5921. form of the output.
  5922. For reasons to be discussed later, we shall find it convenient to
  5923. record the output as follows: Moving one step up is represented by
  5924. appending a `1' to a list; moving one step right is represented by
  5925. adding unity to the element at the end of the list. Thus, for example,
  5926. the net effect of ``(up, right, right, up, right)'' is to append
  5927. $(3,2)$.
  5928. The list is kept in a global array called |move|. Before starting the
  5929. algorithm, \MF\ should check that $\\{move\_ptr}+\lfloor y_3\rfloor
  5930. -\lfloor y_0\rfloor\L\\{move\_size}$, so that the list won't exceed
  5931. the bounds of this array.
  5932. @<Glob...@>=
  5933. @!move:array[0..move_size] of integer; {the recorded moves}
  5934. @!move_ptr:0..move_size; {the number of items in the |move| list}
  5935. @ When bisection occurs, we ``push'' the subproblem corresponding
  5936. to the right-hand subinterval onto the |bisect_stack| while
  5937. we continue to work on the left-hand subinterval. Thus, the |bisect_stack|
  5938. will hold $(X_1,X_2,X_3,R,m,Y_1,Y_2,Y_3,S,n,l)$ values for
  5939. subproblems yet to be tackled.
  5940. At most 15 subproblems will be on the stack at once (namely, for
  5941. $l=15$,~16, \dots,~29); but the stack is bigger than this, because
  5942. it is used also for more complicated bisection algorithms.
  5943. @d stack_x1==bisect_stack[bisect_ptr] {stacked value of $X_1$}
  5944. @d stack_x2==bisect_stack[bisect_ptr+1] {stacked value of $X_2$}
  5945. @d stack_x3==bisect_stack[bisect_ptr+2] {stacked value of $X_3$}
  5946. @d stack_r==bisect_stack[bisect_ptr+3] {stacked value of $R$}
  5947. @d stack_m==bisect_stack[bisect_ptr+4] {stacked value of $m$}
  5948. @d stack_y1==bisect_stack[bisect_ptr+5] {stacked value of $Y_1$}
  5949. @d stack_y2==bisect_stack[bisect_ptr+6] {stacked value of $Y_2$}
  5950. @d stack_y3==bisect_stack[bisect_ptr+7] {stacked value of $Y_3$}
  5951. @d stack_s==bisect_stack[bisect_ptr+8] {stacked value of $S$}
  5952. @d stack_n==bisect_stack[bisect_ptr+9] {stacked value of $n$}
  5953. @d stack_l==bisect_stack[bisect_ptr+10] {stacked value of $l$}
  5954. @d move_increment=11 {number of items pushed by |make_moves|}
  5955. @<Glob...@>=
  5956. @!bisect_stack:array[0..bistack_size] of integer;
  5957. @!bisect_ptr:0..bistack_size;
  5958. @ @<Check the ``constant'' values...@>=
  5959. if 15*move_increment>bistack_size then bad:=31;
  5960. @ The |make_moves| subroutine is given |scaled| values $(x_0,x_1,x_2,x_3)$
  5961. and $(y_0,y_1,y_2,y_3)$ that represent monotone-nondecreasing polynomials;
  5962. it makes $\lfloor x_3+\xi\rfloor-\lfloor x_0+\xi\rfloor$ rightward moves
  5963. and $\lfloor y_3+\eta\rfloor-\lfloor y_0+\eta\rfloor$ upward moves, as
  5964. explained earlier.  (Here $\lfloor x+\xi\rfloor$ actually stands for
  5965. $\lfloor x/2^{16}-|xi_corr|\rfloor$, if $x$ is regarded as an integer
  5966. without scaling.) The unscaled integers $x_k$ and~$y_k$ should be less
  5967. than $2^{28}$ in magnitude.
  5968. It is assumed that $|move_ptr| + \lfloor y_3+\eta\rfloor -
  5969. \lfloor y_0+\eta\rfloor < |move_size|$ when this procedure is called,
  5970. so that the capacity of the |move| array will not be exceeded.
  5971. The variables |r| and |s| in this procedure stand respectively for
  5972. $R-|xi_corr|$ and $S-|eta_corr|$ in the theory discussed above.
  5973. @p procedure make_moves(@!xx0,@!xx1,@!xx2,@!xx3,@!yy0,@!yy1,@!yy2,@!yy3:
  5974.   scaled;@!xi_corr,@!eta_corr:small_number);
  5975. label continue, done, exit;
  5976. var @!x1,@!x2,@!x3,@!m,@!r,@!y1,@!y2,@!y3,@!n,@!s,@!l:integer;
  5977.   {bisection variables explained above}
  5978. @!q,@!t,@!u,@!x2a,@!x3a,@!y2a,@!y3a:integer; {additional temporary registers}
  5979. begin if (xx3<xx0)or(yy3<yy0) then confusion("m");
  5980. @:this can't happen m}{\quad m@>
  5981. l:=16; bisect_ptr:=0;@/
  5982. x1:=xx1-xx0; x2:=xx2-xx1; x3:=xx3-xx2;
  5983. if xx0>=xi_corr then r:=(xx0-xi_corr) mod unity
  5984. else r:=unity-1-((-xx0+xi_corr-1) mod unity);
  5985. m:=(xx3-xx0+r) div unity;@/
  5986. y1:=yy1-yy0; y2:=yy2-yy1; y3:=yy3-yy2;
  5987. if yy0>=eta_corr then s:=(yy0-eta_corr) mod unity
  5988. else s:=unity-1-((-yy0+eta_corr-1) mod unity);
  5989. n:=(yy3-yy0+s) div unity;@/
  5990. if (xx3-xx0>=fraction_one)or(yy3-yy0>=fraction_one) then
  5991.   @<Divide the variables by two, to avoid overflow problems@>;
  5992. loop@+  begin continue:@<Make moves for current subinterval;
  5993.     if bisection is necessary, push the second subinterval
  5994.     onto the stack, and |goto continue| in order to handle
  5995.     the first subinterval@>;
  5996.   if bisect_ptr=0 then return;
  5997.   @<Remove a subproblem for |make_moves| from the stack@>;
  5998.   end;
  5999. exit: end;
  6000. @ @<Remove a subproblem for |make_moves| from the stack@>=
  6001. bisect_ptr:=bisect_ptr-move_increment;@/
  6002. x1:=stack_x1; x2:=stack_x2; x3:=stack_x3; r:=stack_r; m:=stack_m;@/
  6003. y1:=stack_y1; y2:=stack_y2; y3:=stack_y3; s:=stack_s; n:=stack_n;@/
  6004. l:=stack_l
  6005. @ Our variables |(x1,x2,x3)| correspond to $(X_1,X_2,X_3)$ in the notation
  6006. of the theory developed above. We need to keep them less than $2^{28}$
  6007. in order to avoid integer overflow in weird circumstances.
  6008. For example, data like $x_0=-2^{28}+2^{16}-1$ and $x_1=x_2=x_3=2^{28}-1$
  6009. would otherwise be problematical. Hence this part of the code is
  6010. needed, if only to thwart malicious users.
  6011. @<Divide the variables by two, to avoid overflow problems@>=
  6012. begin x1:=half(x1+xi_corr); x2:=half(x2+xi_corr); x3:=half(x3+xi_corr);
  6013. r:=half(r+xi_corr);@/
  6014. y1:=half(y1+eta_corr); y2:=half(y2+eta_corr); y3:=half(y3+eta_corr);
  6015. s:=half(s+eta_corr);@/
  6016. l:=15;
  6017. @ @<Make moves...@>=
  6018. if m=0 then @<Move upward |n| steps@>
  6019. else if n=0 then @<Move to the right |m| steps@>
  6020. else if m+n=2 then @<Make one move of each kind@>
  6021. else  begin incr(l); stack_l:=l;@/
  6022.   stack_x3:=x3; stack_x2:=half(x2+x3+xi_corr); x2:=half(x1+x2+xi_corr);
  6023.   x3:=half(x2+stack_x2+xi_corr); stack_x1:=x3;@/
  6024.   r:=r+r+xi_corr; t:=x1+x2+x3+r;@/
  6025.   q:=t div two_to_the[l]; stack_r:=t mod two_to_the[l];@/
  6026.   stack_m:=m-q; m:=q;@/
  6027.   stack_y3:=y3; stack_y2:=half(y2+y3+eta_corr); y2:=half(y1+y2+eta_corr);
  6028.   y3:=half(y2+stack_y2+eta_corr); stack_y1:=y3;@/
  6029.   s:=s+s+eta_corr; u:=y1+y2+y3+s;@/
  6030.   q:=u div two_to_the[l]; stack_s:=u mod two_to_the[l];@/
  6031.   stack_n:=n-q; n:=q;@/
  6032.   bisect_ptr:=bisect_ptr+move_increment; goto continue;
  6033.   end
  6034. @ @<Move upward |n| steps@>=
  6035. while n>0 do
  6036.   begin incr(move_ptr); move[move_ptr]:=1; decr(n);
  6037.   end
  6038. @ @<Move to the right |m| steps@>=
  6039. move[move_ptr]:=move[move_ptr]+m
  6040. @ @<Make one move of each kind@>=
  6041. begin r:=two_to_the[l]-r; s:=two_to_the[l]-s;@/
  6042. while l<30 do
  6043.   begin x3a:=x3; x2a:=half(x2+x3+xi_corr); x2:=half(x1+x2+xi_corr);
  6044.   x3:=half(x2+x2a+xi_corr);
  6045.   t:=x1+x2+x3; r:=r+r-xi_corr;@/
  6046.   y3a:=y3; y2a:=half(y2+y3+eta_corr); y2:=half(y1+y2+eta_corr);
  6047.   y3:=half(y2+y2a+eta_corr);
  6048.   u:=y1+y2+y3; s:=s+s-eta_corr;@/
  6049.   if t<r then if u<s then @<Switch to the right subinterval@>
  6050.     else  begin @<Move up then right@>; goto done;
  6051.       end
  6052.   else if u<s then
  6053.     begin @<Move right then up@>; goto done;
  6054.     end;
  6055.   incr(l);
  6056.   end;
  6057. r:=r-xi_corr; s:=s-eta_corr;
  6058. if ab_vs_cd(x1+x2+x3,s,y1+y2+y3,r)-xi_corr>=0 then @<Move right then up@>
  6059.   else @<Move up then right@>;
  6060. done:
  6061. @ @<Switch to the right subinterval@>=
  6062. begin x1:=x3; x2:=x2a; x3:=x3a; r:=r-t;
  6063. y1:=y3; y2:=y2a; y3:=y3a; s:=s-u;
  6064. @ @<Move right then up@>=
  6065. begin incr(move[move_ptr]); incr(move_ptr); move[move_ptr]:=1;
  6066. @ @<Move up then right@>=
  6067. begin incr(move_ptr); move[move_ptr]:=2;
  6068. @ After |make_moves| has acted, possibly for several curves that move toward
  6069. the same octant, a ``smoothing'' operation might be done on the |move| array.
  6070. This removes optical glitches that can arise even when the curve has been
  6071. digitized without rounding errors.
  6072. The smoothing process replaces the integers $a_0\ldots a_n$ in
  6073. |move[b..t]| by ``smoothed'' integers $a_0'\ldots a_n'$ defined as
  6074. follows:
  6075. $$a_k'=a_k+\delta\k-\delta_k;\qquad
  6076. \delta_k=\cases{+1,&if $1<k<n$ and $a_{k-2}\G a_{k-1}\ll a_k\G a\k$;\cr
  6077. -1,&if $1<k<n$ and $a_{k-2}\L a_{k-1}\gg a_k\L a\k$;\cr
  6078. 0,&otherwise.\cr}$$
  6079. Here $a\ll b$ means that $a\L b-2$, and $a\gg b$ means that $a\G b+2$.
  6080. The smoothing operation is symmetric in the sense that, if $a_0\ldots a_n$
  6081. smoothes to $a_0'\ldots a_n'$, then the reverse sequence $a_n\ldots a_0$
  6082. smoothes to $a_n'\ldots a_0'$; also the complementary sequence
  6083. $(m-a_0)\ldots(m-a_n)$ smoothes to $(m-a_0')\ldots(m-a_n')$.
  6084. We have $a_0'+\cdots+a_n'=a_0+\cdots+a_n$ because $\delta_0=\delta_{n+1}=0$.
  6085. @p procedure smooth_moves(@!b,@!t:integer);
  6086. var@!k:1..move_size; {index into |move|}
  6087. @!a,@!aa,@!aaa:integer; {original values of |move[k],move[k-1],move[k-2]|}
  6088. begin if t-b>=3 then
  6089.   begin k:=b+2; aa:=move[k-1]; aaa:=move[k-2];
  6090.   repeat a:=move[k];
  6091.   if abs(a-aa)>1 then
  6092.     @<Increase and decrease |move[k-1]| and |move[k]| by $\delta_k$@>;
  6093.   incr(k); aaa:=aa; aa:=a;
  6094.   until k=t;
  6095.   end;
  6096. @ @<Increase and decrease |move[k-1]| and |move[k]| by $\delta_k$@>=
  6097. if a>aa then
  6098.   begin if aaa>=aa then if a>=move[k+1] then
  6099.     begin incr(move[k-1]); move[k]:=a-1;
  6100.     end;
  6101.   end
  6102. else  begin if aaa<=aa then if a<=move[k+1] then
  6103.     begin decr(move[k-1]); move[k]:=a+1;
  6104.     end;
  6105.   end
  6106. @* \[20] Edge structures.
  6107. Now we come to \MF's internal scheme for representing what the user can
  6108. actually ``see,'' the edges between pixels. Each pixel has an integer
  6109. weight, obtained by summing the weights on all edges to its left. \MF\
  6110. represents only the nonzero edge weights, since most of the edges are
  6111. weightless; in this way, the data storage requirements grow only linearly
  6112. with respect to the number of pixels per point, even though two-dimensional
  6113. data is being represented. (Well, the actual dependence on the underlying
  6114. resolution is order $n\log n$, but the the $\log n$ factor is buried in our
  6115. implicit restriction on the maximum raster size.) The sum of all edge
  6116. weights in each row should be zero.
  6117. The data structure for edge weights must be compact and flexible,
  6118. yet it should support efficient updating and display operations. We
  6119. want to be able to have many different edge structures in memory at
  6120. once, and we want the computer to be able to translate them, reflect them,
  6121. and/or merge them together with relative ease.
  6122. \MF's solution to this problem requires one single-word node per
  6123. nonzero edge weight, plus one two-word node for each row in a contiguous
  6124. set of rows. There's also a header node that provides global information
  6125. about the entire structure.
  6126. @ Let's consider the edge-weight nodes first. The |info| field of such
  6127. nodes contains both an $m$~value and a weight~$w$, in the form
  6128. $8m+w+c$, where $c$ is a constant that depends on data found in the header.
  6129. We shall consider $c$ in detail later; for now, it's best just to think
  6130. of it as a way to compensate for the fact that $m$ and~$w$ can be negative,
  6131. together with the fact that an |info| field must have a value between
  6132. |min_halfword| and |max_halfword|. The $m$ value is an unscaled $x$~coordinate,
  6133. so it satisfies $\vert m\vert<
  6134. 4096$; the $w$ value is always in the range $1\L\vert w\vert\L3$. We can
  6135. unpack the data in the |info| field by fetching |ho(info(p))=
  6136. info(p)-min_halfword| and dividing this nonnegative number by~8;
  6137. the constant~$c$ will be chosen so that the remainder of this division
  6138. is $4+w$. Thus, for example, a remainder of~3 will correspond to
  6139. the edge weight $w=-1$.
  6140. Every row of an edge structure contains two lists of such edge-weight
  6141. nodes, called the |sorted| and |unsorted| lists, linked together by their
  6142. |link| fields in the normal way. The difference between them is that we
  6143. always have |info(p)<=info(link(p))| in the |sorted| list, but there's no
  6144. such restriction on the elements of the |unsorted| list. The reason for
  6145. this distinction is that it would take unnecessarily long to maintain
  6146. edge-weight lists in sorted order while they're being updated; but when we
  6147. need to process an entire row from left to right in order of the
  6148. $m$~values, it's fairly easy and quick to sort a short list of unsorted
  6149. elements and to merge them into place among their sorted cohorts.
  6150. Furthermore, the fact that the |unsorted| list is empty can sometimes be
  6151. used to good advantage, because it allows us to conclude that a particular
  6152. row has not changed since the last time we sorted it.
  6153. The final |link| of the |sorted| list will be |sentinel|, which points to
  6154. a special one-word node whose |info| field is essentially infinite; this
  6155. facilitates the sorting and merging operations. The final |link| of the
  6156. |unsorted| list will be either |null| or |void|, where |void=null+1|
  6157. is used to avoid redisplaying data that has not changed:
  6158. A |void| value is stored at the head of the
  6159. unsorted list whenever the corresponding row has been displayed.
  6160. @d zero_w=4
  6161. @d void==null+1
  6162. @<Initialize table entries...@>=
  6163. info(sentinel):=max_halfword; {|link(sentinel)=null|}
  6164. @ The rows themselves are represented by row-header nodes that
  6165. contain four link fields. Two of these four, |sorted| and |unsorted|,
  6166. point to the first items of the edge-weight lists just mentioned.
  6167. The other two, |link| and |knil|, point to the headers of the two
  6168. adjacent rows. If |p| points to the header for row number~|n|, then
  6169. |link(p)| points up to the header for row~|n+1|, and |knil(p)| points
  6170. down to the header for row~|n-1|. This double linking makes it
  6171. convenient to move through consecutive rows either upward or downward;
  6172. as usual, we have |link(knil(p))=knil(link(p))=p| for all row headers~|p|.
  6173. The row associated with a given value of |n| contains weights for
  6174. edges that run between the lattice points |(m,n)| and |(m,n+1)|.
  6175. @d knil==info {inverse of the |link| field, in a doubly linked list}
  6176. @d sorted_loc(#)==#+1 {where the |sorted| link field resides}
  6177. @d sorted(#)==link(sorted_loc(#)) {beginning of the list of sorted edge weights}
  6178. @d unsorted(#)==info(#+1) {beginning of the list of unsorted edge weights}
  6179. @d row_node_size=2 {number of words in a row header node}
  6180. @ The main header node |h| for an edge structure has |link| and |knil|
  6181. fields that link it above the topmost row and below the bottommost row.
  6182. It also has fields called |m_min|, |m_max|, |n_min|, and |n_max| that
  6183. bound the current extent of the edge data: All |m| values in edge-weight
  6184. nodes should lie between |m_min(h)-4096| and |m_max(h)-4096|, inclusive.
  6185. Furthermore the topmost row header, pointed to by |knil(h)|,
  6186. is for row number |n_max(h)-4096|; the bottommost row header, pointed to by
  6187. |link(h)|, is for row number |n_min(h)-4096|.
  6188. The offset constant |c| that's used in all of the edge-weight data is
  6189. represented implicitly in |m_offset(h)|; its actual value is
  6190. $$\hbox{|c=min_halfword+zero_w+8*m_offset(h)|.}$$
  6191. Notice that it's possible to shift an entire edge structure by an
  6192. amount $(\Delta m,\Delta n)$ by adding $\Delta n$ to |n_min(h)| and |n_max(h)|,
  6193. adding $\Delta m$ to |m_min(h)| and |m_max(h)|, and subtracting
  6194. $\Delta m$ from |m_offset(h)|;
  6195. none of the other edge data needs to be modified. Initially the |m_offset|
  6196. field is~4096, but it will change if the user requests such a shift.
  6197. The contents of these five fields should always be positive and less than
  6198. 8192; |n_max| should, in fact, be less than 8191.  Furthermore
  6199. |m_min+m_offset-4096| and |m_max+m_offset-4096| must also lie strictly
  6200. between 0 and 8192, so that the |info| fields of edge-weight nodes will
  6201. fit in a halfword.
  6202. The header node of an edge structure also contains two somewhat unusual
  6203. fields that are called |last_window(h)| and |last_window_time(h)|. When this
  6204. structure is displayed in window~|k| of the user's screen, after that
  6205. window has been updated |t| times, \MF\ sets |last_window(h):=k| and
  6206. |last_window_time(h):=t|; it also sets |unsorted(p):=void| for all row
  6207. headers~|p|, after merging any existing unsorted weights with the sorted
  6208. ones.  A subsequent display in the same window will be able to avoid
  6209. redisplaying rows whose |unsorted| list is still |void|, if the window
  6210. hasn't been used for something else in the meantime.
  6211. A pointer to the row header of row |n_pos(h)-4096| is provided in
  6212. |n_rover(h)|. Most of the algorithms that update an edge structure
  6213. are able to get by without random row references; they usually
  6214. access rows that are neighbors of each other or of the current |n_pos| row.
  6215. Exception: If |link(h)=h| (so that the edge structure contains
  6216. no rows), we have |n_rover(h)=h|, and |n_pos(h)| is irrelevant.
  6217. @d zero_field=4096 {amount added to coordinates to make them positive}
  6218. @d n_min(#)==info(#+1) {minimum row number present, plus |zero_field|}
  6219. @d n_max(#)==link(#+1) {maximum row number present, plus |zero_field|}
  6220. @d m_min(#)==info(#+2) {minimum column number present, plus |zero_field|}
  6221. @d m_max(#)==link(#+2) {maximum column number present, plus |zero_field|}
  6222. @d m_offset(#)==info(#+3) {translation of $m$ data in edge-weight nodes}
  6223. @d last_window(#)==link(#+3) {the last display went into this window}
  6224. @d last_window_time(#)==mem[#+4].int {after this many window updates}
  6225. @d n_pos(#)==info(#+5) {the row currently in |n_rover|, plus |zero_field|}
  6226. @d n_rover(#)==link(#+5) {a row recently referenced}
  6227. @d edge_header_size=6 {number of words in an edge-structure header}
  6228. @d valid_range(#)==(abs(#-4096)<4096) {is |#| strictly between 0 and 8192?}
  6229. @d empty_edges(#)==link(#)=# {are there no rows in this edge header?}
  6230. @p procedure init_edges(@!h:pointer); {initialize an edge header to null values}
  6231. begin knil(h):=h; link(h):=h;@/
  6232. n_min(h):=zero_field+4095; n_max(h):=zero_field-4095;
  6233. m_min(h):=zero_field+4095; m_max(h):=zero_field-4095;
  6234. m_offset(h):=zero_field;@/
  6235. last_window(h):=0; last_window_time(h):=0;@/
  6236. n_rover(h):=h; n_pos(h):=0;@/
  6237. @ When a lot of work is being done on a particular edge structure, we plant
  6238. a pointer to its main header in the global variable |cur_edges|.
  6239. This saves us from having to pass this pointer as a parameter over and
  6240. over again between subroutines.
  6241. Similarly, |cur_wt| is a global weight that is being used by several
  6242. procedures at once.
  6243. @<Glob...@>=
  6244. @!cur_edges:pointer; {the edge structure of current interest}
  6245. @!cur_wt:integer; {the edge weight of current interest}
  6246. @ The |fix_offset| routine goes through all the edge-weight nodes of
  6247. |cur_edges| and adds a constant to their |info| fields, so that
  6248. |m_offset(cur_edges)| can be brought back to |zero_field|. (This
  6249. is necessary only in unusual cases when the offset has gotten too
  6250. large or too small.)
  6251. @p procedure fix_offset;
  6252. var @!p,@!q:pointer; {list traversers}
  6253. @!delta:integer; {the amount of change}
  6254. begin delta:=8*(m_offset(cur_edges)-zero_field);
  6255. m_offset(cur_edges):=zero_field;
  6256. q:=link(cur_edges);
  6257. while q<>cur_edges do
  6258.   begin p:=sorted(q);
  6259.   while p<>sentinel do
  6260.     begin info(p):=info(p)-delta; p:=link(p);
  6261.     end;
  6262.   p:=unsorted(q);
  6263.   while p>void do
  6264.     begin info(p):=info(p)-delta; p:=link(p);
  6265.     end;
  6266.   q:=link(q);
  6267.   end;
  6268. @ The |edge_prep| routine makes the |cur_edges| structure ready to
  6269. accept new data whose coordinates satisfy |ml<=m<=mr| and |nl<=n<=nr-1|,
  6270. assuming that |-4096<ml<=mr<4096| and |-4096<nl<=nr<4096|. It makes
  6271. appropriate adjustments to |m_min|, |m_max|, |n_min|, and |n_max|,
  6272. adding new empty rows if necessary.
  6273. @p procedure edge_prep(@!ml,@!mr,@!nl,@!nr:integer);
  6274. var @!delta:halfword; {amount of change}
  6275. @!p,@!q:pointer; {for list manipulation}
  6276. begin ml:=ml+zero_field; mr:=mr+zero_field;
  6277. nl:=nl+zero_field; nr:=nr-1+zero_field;@/
  6278. if ml<m_min(cur_edges) then m_min(cur_edges):=ml;
  6279. if mr>m_max(cur_edges) then m_max(cur_edges):=mr;
  6280. if not valid_range(m_min(cur_edges)+m_offset(cur_edges)-zero_field) or@|
  6281.  not valid_range(m_max(cur_edges)+m_offset(cur_edges)-zero_field) then
  6282.   fix_offset;
  6283. if empty_edges(cur_edges) then {there are no rows}
  6284.   begin n_min(cur_edges):=nr+1; n_max(cur_edges):=nr;
  6285.   end;
  6286. if nl<n_min(cur_edges) then
  6287.   @<Insert exactly |n_min(cur_edges)-nl| empty rows at the bottom@>;
  6288. if nr>n_max(cur_edges) then
  6289.   @<Insert exactly |nr-n_max(cur_edges)| empty rows at the top@>;
  6290. @ @<Insert exactly |n_min(cur_edges)-nl| empty rows at the bottom@>=
  6291. begin delta:=n_min(cur_edges)-nl; n_min(cur_edges):=nl;
  6292. p:=link(cur_edges);
  6293. repeat q:=get_node(row_node_size); sorted(q):=sentinel; unsorted(q):=void;
  6294. knil(p):=q; link(q):=p; p:=q; decr(delta);
  6295. until delta=0;
  6296. knil(p):=cur_edges; link(cur_edges):=p;
  6297. if n_rover(cur_edges)=cur_edges then n_pos(cur_edges):=nl-1;
  6298. @ @<Insert exactly |nr-n_max(cur_edges)| empty rows at the top@>=
  6299. begin delta:=nr-n_max(cur_edges); n_max(cur_edges):=nr;
  6300. p:=knil(cur_edges);
  6301. repeat q:=get_node(row_node_size); sorted(q):=sentinel; unsorted(q):=void;
  6302. link(p):=q; knil(q):=p; p:=q; decr(delta);
  6303. until delta=0;
  6304. link(p):=cur_edges; knil(cur_edges):=p;
  6305. if n_rover(cur_edges)=cur_edges then n_pos(cur_edges):=nr+1;
  6306. @ The |print_edges| subroutine gives a symbolic rendition of an edge
  6307. structure, for use in `\&{show}' commands. A rather terse output
  6308. format has been chosen since edge structures can grow quite large.
  6309. @<Declare subroutines for printing expressions@>=
  6310. @t\4@>@<Declare the procedure called |print_weight|@>@;@/
  6311. procedure print_edges(@!s:str_number;@!nuline:boolean;@!x_off,@!y_off:integer);
  6312. var @!p,@!q,@!r:pointer; {for list traversal}
  6313. @!n:integer; {row number}
  6314. begin print_diagnostic("Edge structure",s,nuline);
  6315. p:=knil(cur_edges); n:=n_max(cur_edges)-zero_field;
  6316. while p<>cur_edges do
  6317.   begin q:=unsorted(p); r:=sorted(p);
  6318.   if(q>void)or(r<>sentinel) then
  6319.     begin print_nl("row "); print_int(n+y_off); print_char(":");
  6320.     while q>void do
  6321.       begin print_weight(q,x_off); q:=link(q);
  6322.       end;
  6323.     print(" |");
  6324.     while r<>sentinel do
  6325.       begin print_weight(r,x_off); r:=link(r);
  6326.       end;
  6327.     end;
  6328.   p:=knil(p); decr(n);
  6329.   end;
  6330. end_diagnostic(true);
  6331. @ @<Declare the procedure called |print_weight|@>=
  6332. procedure print_weight(@!q:pointer;@!x_off:integer);
  6333. var @!w,@!m:integer; {unpacked weight and coordinate}
  6334. @!d:integer; {temporary data register}
  6335. begin d:=ho(info(q)); w:=d mod 8; m:=(d div 8)-m_offset(cur_edges);
  6336. if file_offset>max_print_line-9 then print_nl(" ")
  6337. else print_char(" ");
  6338. print_int(m+x_off);
  6339. while w>zero_w do
  6340.   begin print_char("+"); decr(w);
  6341.   end;
  6342. while w<zero_w do
  6343.   begin print_char("-"); incr(w);
  6344.   end;
  6345. @ Here's a trivial subroutine that copies an edge structure. (Let's hope
  6346. that the given structure isn't too gigantic.)
  6347. @p function copy_edges(@!h:pointer):pointer;
  6348. var @!p,@!r:pointer; {variables that traverse the given structure}
  6349. @!hh,@!pp,@!qq,@!rr,@!ss:pointer; {variables that traverse the new structure}
  6350. begin hh:=get_node(edge_header_size);
  6351. mem[hh+1]:=mem[h+1]; mem[hh+2]:=mem[h+2];
  6352. mem[hh+3]:=mem[h+3]; mem[hh+4]:=mem[h+4]; {we've now copied |n_min|, |n_max|,
  6353.   |m_min|, |m_max|, |m_offset|, |last_window|, and |last_window_time|}
  6354. n_pos(hh):=n_max(hh)+1;n_rover(hh):=hh;@/
  6355. p:=link(h); qq:=hh;
  6356. while p<>h do
  6357.   begin pp:=get_node(row_node_size); link(qq):=pp; knil(pp):=qq;
  6358.   @<Copy both |sorted| and |unsorted| lists of |p| to |pp|@>;
  6359.   p:=link(p); qq:=pp;
  6360.   end;
  6361. link(qq):=hh; knil(hh):=qq;
  6362. copy_edges:=hh;
  6363. @ @<Copy both |sorted| and |unsorted|...@>=
  6364. r:=sorted(p); rr:=sorted_loc(pp); {|link(rr)=sorted(pp)|}
  6365. while r<>sentinel do
  6366.   begin ss:=get_avail; link(rr):=ss; rr:=ss; info(rr):=info(r);@/
  6367.   r:=link(r);
  6368.   end;
  6369. link(rr):=sentinel;@/
  6370. r:=unsorted(p); rr:=temp_head;
  6371. while r>void do
  6372.   begin ss:=get_avail; link(rr):=ss; rr:=ss; info(rr):=info(r);@/
  6373.   r:=link(r);
  6374.   end;
  6375. link(rr):=r; unsorted(pp):=link(temp_head)
  6376. @ Another trivial routine flips |cur_edges| about the |x|-axis
  6377. (i.e., negates all the |y| coordinates), assuming that at least
  6378. one row is present.
  6379. @p procedure y_reflect_edges;
  6380. var @!p,@!q,@!r:pointer; {list manipulation registers}
  6381. begin p:=n_min(cur_edges);
  6382. n_min(cur_edges):=zero_field+zero_field-1-n_max(cur_edges);
  6383. n_max(cur_edges):=zero_field+zero_field-1-p;
  6384. n_pos(cur_edges):=zero_field+zero_field-1-n_pos(cur_edges);@/
  6385. p:=link(cur_edges); q:=cur_edges; {we assume that |p<>q|}
  6386. repeat r:=link(p); link(p):=q; knil(q):=p; q:=p; p:=r;
  6387. until q=cur_edges;
  6388. last_window_time(cur_edges):=0;
  6389. @ It's somewhat more difficult, yet not too hard, to reflect about the |y|-axis.
  6390. @p procedure x_reflect_edges;
  6391. var @!p,@!q,@!r,@!s:pointer; {list manipulation registers}
  6392. @!m:integer; {|info| fields will be reflected with respect to this number}
  6393. begin p:=m_min(cur_edges);
  6394. m_min(cur_edges):=zero_field+zero_field-m_max(cur_edges);
  6395. m_max(cur_edges):=zero_field+zero_field-p;
  6396. m:=(zero_field+m_offset(cur_edges))*8+zero_w+min_halfword+zero_w+min_halfword;
  6397. m_offset(cur_edges):=zero_field;
  6398. p:=link(cur_edges);
  6399. repeat @<Reflect the edge-and-weight data in |sorted(p)|@>;
  6400. @<Reflect the edge-and-weight data in |unsorted(p)|@>;
  6401. p:=link(p);
  6402. until p=cur_edges;
  6403. last_window_time(cur_edges):=0;
  6404. @ We want to change the sign of the weight as we change the sign of the
  6405. |x|~coordinate. Fortunately, it's easier to do this than to negate
  6406. one without the other.
  6407. @<Reflect the edge-and-weight data in |unsorted(p)|@>=
  6408. q:=unsorted(p);
  6409. while q>void do
  6410.   begin info(q):=m-info(q); q:=link(q);
  6411.   end
  6412. @ Reversing the order of a linked list is best thought of as the process of
  6413. popping nodes off one stack and pushing them on another. In this case we
  6414. pop from stack~|q| and push to stack~|r|.
  6415. @<Reflect the edge-and-weight data in |sorted(p)|@>=
  6416. q:=sorted(p); r:=sentinel;
  6417. while q<>sentinel do
  6418.   begin s:=link(q); link(q):=r; r:=q; info(r):=m-info(q); q:=s;
  6419.   end;
  6420. sorted(p):=r
  6421. @ Now let's multiply all the $y$~coordinates of a nonempty edge structure
  6422. by a small integer $s>1$:
  6423. @p procedure y_scale_edges(@!s:integer);
  6424. var @!p,@!q,@!pp,@!r,@!rr,@!ss:pointer; {list manipulation registers}
  6425. @!t:integer; {replication counter}
  6426. begin if (s*(n_max(cur_edges)+1-zero_field)>=4096) or@|
  6427.  (s*(n_min(cur_edges)-zero_field)<=-4096) then
  6428.   begin print_err("Scaled picture would be too big");
  6429. @.Scaled picture...big@>
  6430.   help3("I can't yscale the picture as requested---it would")@/
  6431.     ("make some coordinates too large or too small.")@/
  6432.     ("Proceed, and I'll omit the transformation.");
  6433.   put_get_error;
  6434.   end
  6435. else  begin n_max(cur_edges):=s*(n_max(cur_edges)+1-zero_field)-1+zero_field;
  6436.   n_min(cur_edges):=s*(n_min(cur_edges)-zero_field)+zero_field;
  6437.   @<Replicate every row exactly $s$ times@>;
  6438.   last_window_time(cur_edges):=0;
  6439.   end;
  6440. @ @<Replicate...@>=
  6441. p:=cur_edges;
  6442. repeat q:=p; p:=link(p);
  6443. for t:=2 to s do
  6444.   begin pp:=get_node(row_node_size); link(q):=pp; knil(p):=pp;
  6445.   link(pp):=p; knil(pp):=q; q:=pp;
  6446.   @<Copy both |sorted| and |unsorted|...@>;
  6447.   end;
  6448. until link(p)=cur_edges
  6449. @ Scaling the $x$~coordinates is, of course, our next task.
  6450. @p procedure x_scale_edges(@!s:integer);
  6451. var @!p,@!q:pointer; {list manipulation registers}
  6452. @!t:0..65535; {unpacked |info| field}
  6453. @!w:0..7; {unpacked weight}
  6454. @!delta:integer; {amount added to scaled |info|}
  6455. begin if (s*(m_max(cur_edges)-zero_field)>=4096) or@|
  6456.  (s*(m_min(cur_edges)-zero_field)<=-4096) then
  6457.   begin print_err("Scaled picture would be too big");
  6458. @.Scaled picture...big@>
  6459.   help3("I can't xscale the picture as requested---it would")@/
  6460.     ("make some coordinates too large or too small.")@/
  6461.     ("Proceed, and I'll omit the transformation.");
  6462.   put_get_error;
  6463.   end
  6464. else if (m_max(cur_edges)<>zero_field)or(m_min(cur_edges)<>zero_field) then
  6465.   begin m_max(cur_edges):=s*(m_max(cur_edges)-zero_field)+zero_field;
  6466.   m_min(cur_edges):=s*(m_min(cur_edges)-zero_field)+zero_field;
  6467.   delta:=8*(zero_field-s*m_offset(cur_edges))+min_halfword;
  6468.   m_offset(cur_edges):=zero_field;@/
  6469.   @<Scale the $x$~coordinates of each row by $s$@>;
  6470.   last_window_time(cur_edges):=0;
  6471.   end;
  6472. @ The multiplications cannot overflow because we know that |s<4096|.
  6473. @<Scale the $x$~coordinates of each row by $s$@>=
  6474. q:=link(cur_edges);
  6475. repeat p:=sorted(q);
  6476. while p<>sentinel do
  6477.   begin t:=ho(info(p)); w:=t mod 8; info(p):=(t-w)*s+w+delta; p:=link(p);
  6478.   end;
  6479. p:=unsorted(q);
  6480. while p>void do
  6481.   begin t:=ho(info(p)); w:=t mod 8; info(p):=(t-w)*s+w+delta; p:=link(p);
  6482.   end;
  6483. q:=link(q);
  6484. until q=cur_edges
  6485. @ Here is a routine that changes the signs of all the weights, without
  6486. changing anything else.
  6487. @p procedure negate_edges(@!h:pointer);
  6488. label done;
  6489. var @!p,@!q,@!r,@!s,@!t,@!u:pointer; {structure traversers}
  6490. begin p:=link(h);
  6491. while p<>h do
  6492.   begin q:=unsorted(p);
  6493.   while q>void do
  6494.     begin info(q):=8-2*((ho(info(q))) mod 8)+info(q); q:=link(q);
  6495.     end;
  6496.   q:=sorted(p);
  6497.   if q<>sentinel then
  6498.     begin repeat info(q):=8-2*((ho(info(q))) mod 8)+info(q); q:=link(q);
  6499.     until q=sentinel;
  6500.     @<Put the list |sorted(p)| back into sort@>;
  6501.     end;
  6502.   p:=link(p);
  6503.   end;
  6504. last_window_time(h):=0;
  6505. @ \MF\ would work even if the code in this section were omitted, because
  6506. a list of edge-and-weight data that is sorted only by
  6507. |m| but not~|w| turns out to be good enough for correct operation.
  6508. However, the author decided not to make the program even trickier than
  6509. it is already, since |negate_edges| isn't needed very often.
  6510. The simpler-to-state condition, ``keep the |sorted| list fully sorted,''
  6511. is therefore being preserved at the cost of extra computation.
  6512. @<Put the list |sorted(p)|...@>=
  6513. u:=sorted_loc(p); q:=link(u); r:=q; s:=link(r); {|q=sorted(p)|}
  6514. loop@+  if info(s)>info(r) then
  6515.     begin link(u):=q;
  6516.     if s=sentinel then goto done;
  6517.     u:=r; q:=s; r:=q; s:=link(r);
  6518.     end
  6519.   else  begin t:=s; s:=link(t); link(t):=q; q:=t;
  6520.     end;
  6521. done: link(r):=sentinel
  6522. @ The |unsorted| edges of a row are merged into the |sorted| ones by
  6523. a subroutine called |sort_edges|. It uses simple insertion sort,
  6524. followed by a merge, because the unsorted list is supposedly quite short.
  6525. However, the unsorted list is assumed to be nonempty.
  6526. @p procedure sort_edges(@!h:pointer); {|h| is a row header}
  6527. label done;
  6528. var @!k:halfword; {key register that we compare to |info(q)|}
  6529. @!p,@!q,@!r,@!s:pointer;
  6530. begin r:=unsorted(h); unsorted(h):=null;
  6531. p:=link(r); link(r):=sentinel; link(temp_head):=r;
  6532. while p>void do {sort node |p| into the list that starts at |temp_head|}
  6533.   begin k:=info(p); q:=temp_head;
  6534.   repeat r:=q; q:=link(r);
  6535.   until k<=info(q);
  6536.   link(r):=p; r:=link(p); link(p):=q; p:=r;
  6537.   end;
  6538. @<Merge the |temp_head| list into |sorted(h)|@>;
  6539. @ In this step we use the fact that |sorted(h)=link(sorted_loc(h))|.
  6540. @<Merge the |temp_head| list into |sorted(h)|@>=
  6541. begin r:=sorted_loc(h); q:=link(r); p:=link(temp_head);
  6542. loop@+  begin k:=info(p);
  6543.   while k>info(q) do
  6544.     begin r:=q; q:=link(r);
  6545.     end;
  6546.   link(r):=p; s:=link(p); link(p):=q;
  6547.   if s=sentinel then goto done;
  6548.   r:=p; p:=s;
  6549.   end;
  6550. done:end
  6551. @ The |cull_edges| procedure ``optimizes'' an edge structure by making all
  6552. the pixel weights either |w_out| or~|w_in|. The weight will be~|w_in| after the
  6553. operation if and only if it was in the closed interval |[w_lo,w_hi]|
  6554. before, where |w_lo<=w_hi|. Either |w_out| or |w_in| is zero, while the other is
  6555. $\pm1$, $\pm2$, or $\pm3$. The parameters will be such that zero-weight
  6556. pixels will remain of weight zero.  (This is fortunate,
  6557. because there are infinitely many of them.)
  6558. The procedure also computes the tightest possible bounds on the resulting
  6559. data, by updating |m_min|, |m_max|, |n_min|, and~|n_max|.
  6560. @p procedure cull_edges(@!w_lo,@!w_hi,@!w_out,@!w_in:integer);
  6561. label done;
  6562. var @!p,@!q,@!r,@!s:pointer; {for list manipulation}
  6563. @!w:integer; {new weight after culling}
  6564. @!d:integer; {data register for unpacking}
  6565. @!m:integer; {the previous column number, including |m_offset|}
  6566. @!mm:integer; {the next column number, including |m_offset|}
  6567. @!ww:integer; {accumulated weight before culling}
  6568. @!prev_w:integer; {value of |w| before column |m|}
  6569. @!n,@!min_n,@!max_n:pointer; {current and extreme row numbers}
  6570. @!min_d,@!max_d:pointer; {extremes of the new edge-and-weight data}
  6571. begin min_d:=max_halfword; max_d:=min_halfword;
  6572. min_n:=max_halfword; max_n:=min_halfword;@/
  6573. p:=link(cur_edges); n:=n_min(cur_edges);
  6574. while p<>cur_edges do
  6575.   begin if unsorted(p)>void then sort_edges(p);
  6576.   if sorted(p)<>sentinel then
  6577.     @<Cull superfluous edge-weight entries from |sorted(p)|@>;
  6578.   p:=link(p); incr(n);
  6579.   end;
  6580. @<Delete empty rows at the top and/or bottom;
  6581.   update the boundary values in the header@>;
  6582. last_window_time(cur_edges):=0;
  6583. @ The entire |sorted| list is returned to available memory in this step;
  6584. a new list is built starting (temporarily) at |temp_head|.
  6585. Since several edges can occur at the same column, we need to be looking
  6586. ahead of where the actual culling takes place. This means that it's
  6587. slightly tricky to get the iteration started and stopped.
  6588. @<Cull superfluous...@>=
  6589. begin r:=temp_head; q:=sorted(p); ww:=0; m:=1000000; prev_w:=0;
  6590. loop@+  begin if q=sentinel then mm:=1000000
  6591.   else  begin d:=ho(info(q)); mm:=d div 8; ww:=ww+(d mod 8)-zero_w;
  6592.     end;
  6593.   if mm>m then
  6594.     begin @<Insert an edge-weight for edge |m|, if the new pixel
  6595.       weight has changed@>;
  6596.     if q=sentinel then goto done;
  6597.     end;
  6598.   m:=mm;
  6599.   if ww>=w_lo then if ww<=w_hi then w:=w_in
  6600.     else w:=w_out
  6601.   else w:=w_out;
  6602.   s:=link(q); free_avail(q); q:=s;
  6603.   end;
  6604. done: link(r):=sentinel; sorted(p):=link(temp_head);
  6605. if r<>temp_head then @<Update the max/min amounts@>;
  6606. @ @<Insert an edge-weight for edge |m|, if...@>=
  6607. if w<>prev_w then
  6608.   begin s:=get_avail; link(r):=s;
  6609.   info(s):=8*m+min_halfword+zero_w+w-prev_w;
  6610.   r:=s; prev_w:=w;
  6611.   end
  6612. @ @<Update the max/min amounts@>=
  6613. begin if min_n=max_halfword then min_n:=n;
  6614. max_n:=n;
  6615. if min_d>info(link(temp_head)) then min_d:=info(link(temp_head));
  6616. if max_d<info(r) then max_d:=info(r);
  6617. @ @<Delete empty rows at the top and/or bottom...@>=
  6618. if min_n>max_n then @<Delete all the row headers@>
  6619. else  begin n:=n_min(cur_edges); n_min(cur_edges):=min_n;
  6620.   while min_n>n do
  6621.     begin p:=link(cur_edges); link(cur_edges):=link(p);
  6622.     knil(link(p)):=cur_edges;
  6623.     free_node(p,row_node_size); incr(n);
  6624.     end;
  6625.   n:=n_max(cur_edges); n_max(cur_edges):=max_n;
  6626.   n_pos(cur_edges):=max_n+1; n_rover(cur_edges):=cur_edges;
  6627.   while max_n<n do
  6628.     begin p:=knil(cur_edges); knil(cur_edges):=knil(p);
  6629.     link(knil(p)):=cur_edges;
  6630.     free_node(p,row_node_size); decr(n);
  6631.     end;
  6632.   m_min(cur_edges):=((ho(min_d)) div 8)-m_offset(cur_edges)+zero_field;
  6633.   m_max(cur_edges):=((ho(max_d)) div 8)-m_offset(cur_edges)+zero_field;
  6634.   end
  6635. @ We get here if the edges have been entirely culled away.
  6636. @<Delete all the row headers@>=
  6637. begin p:=link(cur_edges);
  6638. while p<>cur_edges do
  6639.   begin q:=link(p); free_node(p,row_node_size); p:=q;
  6640.   end;
  6641. init_edges(cur_edges);
  6642. @ The last and most difficult routine for transforming an edge structure---and
  6643. the most interesting one!---is |xy_swap_edges|, which interchanges the
  6644. r\^^Doles of rows and columns. Its task can be viewed as the job of
  6645. creating an edge structure that contains only horizontal edges, linked
  6646. together in columns, given an edge structure that contains only
  6647. vertical edges linked together in rows; we must do this without changing
  6648. the implied pixel weights.
  6649. Given any two adjacent rows of an edge structure, it is not difficult to
  6650. determine the horizontal edges that lie ``between'' them: We simply look
  6651. for vertically adjacent pixels that have different weight, and insert
  6652. a horizontal edge containing the difference in weights. Every horizontal
  6653. edge determined in this way should be put into an appropriate linked
  6654. list. Since random access to these linked lists is desirable, we use
  6655. the |move| array to hold the list heads. If we work through the given
  6656. edge structure from top to bottom, the constructed lists will not need
  6657. to be sorted, since they will already be in order.
  6658. The following algorithm makes use of some ideas suggested by John Hobby.
  6659. @^Hobby, John Douglas@>
  6660. It assumes that the edge structure is non-null, i.e., that |link(cur_edges)
  6661. <>cur_edges|, hence |m_max(cur_edges)>=m_min(cur_edges)|.
  6662. @p procedure xy_swap_edges; {interchange |x| and |y| in |cur_edges|}
  6663. label done;
  6664. var @!m_magic,@!n_magic:integer; {special values that account for offsets}
  6665. @!p,@!q,@!r,@!s:pointer; {pointers that traverse the given structure}
  6666. @<Other local variables for |xy_swap_edges|@>@;
  6667. begin @<Initialize the array of new edge list heads@>;
  6668. @<Insert blank rows at the top and bottom, and set |p| to the new top row@>;
  6669. @<Compute the magic offset values@>;
  6670. repeat q:=knil(p);@+if unsorted(q)>void then sort_edges(q);
  6671. @<Insert the horizontal edges defined by adjacent rows |p,q|,
  6672.   and destroy row~|p|@>;
  6673. p:=q; n_magic:=n_magic-8;
  6674. until knil(p)=cur_edges;
  6675. free_node(p,row_node_size); {now all original rows have been recycled}
  6676. @<Adjust the header to reflect the new edges@>;
  6677. @ Here we don't bother to keep the |link| entries up to date, since the
  6678. procedure looks only at the |knil| fields as it destroys the former
  6679. edge structure.
  6680. @<Insert blank rows at the top and bottom...@>=
  6681. p:=get_node(row_node_size); sorted(p):=sentinel; unsorted(p):=null;@/
  6682. knil(p):=cur_edges; knil(link(cur_edges)):=p; {the new bottom row}
  6683. p:=get_node(row_node_size); sorted(p):=sentinel;
  6684. knil(p):=knil(cur_edges); {the new top row}
  6685. @ The new lists will become |sorted| lists later, so we initialize
  6686. empty lists to |sentinel|.
  6687. @<Initialize the array of new edge list heads@>=
  6688. m_spread:=m_max(cur_edges)-m_min(cur_edges); {this is |>=0| by assumption}
  6689. if m_spread>move_size then overflow("move table size",move_size);
  6690. @:METAFONT capacity exceeded move table size}{\quad move table size@>
  6691. for j:=0 to m_spread do move[j]:=sentinel
  6692. @ @<Other local variables for |xy_swap_edges|@>=
  6693. @!m_spread:integer; {the difference between |m_max| and |m_min|}
  6694. @!j,@!jj:0..move_size; {indices into |move|}
  6695. @!m,@!mm:integer; {|m| values at vertical edges}
  6696. @!pd,@!rd:integer; {data fields from edge-and-weight nodes}
  6697. @!pm,@!rm:integer; {|m| values from edge-and-weight nodes}
  6698. @!w:integer; {the difference in accumulated weight}
  6699. @!ww:integer; {as much of |w| that can be stored in a single node}
  6700. @!dw:integer; {an increment to be added to |w|}
  6701. @ At the point where we test |w<>0|, variable |w| contains
  6702. the accumulated weight from edges already passed in
  6703. row~|p| minus the accumulated weight from edges already passed in row~|q|.
  6704. @<Insert the horizontal edges defined by adjacent rows |p,q|...@>=
  6705. r:=sorted(p); free_node(p,row_node_size); p:=r;@/
  6706. pd:=ho(info(p)); pm:=pd div 8;@/
  6707. r:=sorted(q); rd:=ho(info(r)); rm:=rd div 8; w:=0;
  6708. loop@+  begin if pm<rm then mm:=pm@+else mm:=rm;
  6709.   if w<>0 then
  6710.     @<Insert horizontal edges of weight |w| between |m| and~|mm|@>;
  6711.   if pd<rd then
  6712.     begin dw:=(pd mod 8)-zero_w;
  6713.     @<Advance pointer |p| to the next vertical edge,
  6714.       after destroying the previous one@>;
  6715.     end
  6716.   else  begin if r=sentinel then goto done; {|rd=pd=ho(max_halfword)|}
  6717.     dw:=-((rd mod 8)-zero_w);
  6718.     @<Advance pointer |r| to the next vertical edge@>;
  6719.     end;
  6720.   m:=mm; w:=w+dw;
  6721.   end;
  6722. done:
  6723. @ @<Advance pointer |r| to the next vertical edge@>=
  6724. r:=link(r); rd:=ho(info(r)); rm:=rd div 8
  6725. @ @<Advance pointer |p| to the next vertical edge...@>=
  6726. s:=link(p); free_avail(p); p:=s; pd:=ho(info(p)); pm:=pd div 8
  6727. @ Certain ``magic'' values are needed to make the following code work,
  6728. because of the various offsets in our data structure. For now, let's not
  6729. worry about their precise values; we shall compute |m_magic| and |n_magic|
  6730. later, after we see what the code looks like.
  6731. @ @<Insert horizontal edges of weight |w| between |m| and~|mm|@>=
  6732. if m<>mm then
  6733.   begin if mm-m_magic>=move_size then confusion("xy");
  6734. @:this can't happen xy}{\quad xy@>
  6735.   extras:=(abs(w)-1) div 3;
  6736.   if extras>0 then
  6737.     begin if w>0 then xw:=+3@+else xw:=-3;
  6738.     ww:=w-extras*xw;
  6739.     end
  6740.   else ww:=w;
  6741.   repeat j:=m-m_magic;
  6742.   for k:=1 to extras do
  6743.     begin s:=get_avail; info(s):=n_magic+xw;
  6744.     link(s):=move[j]; move[j]:=s;
  6745.     end;
  6746.   s:=get_avail; info(s):=n_magic+ww;
  6747.   link(s):=move[j]; move[j]:=s;@/
  6748.   incr(m);
  6749.   until m=mm;
  6750.   end
  6751. @ @<Other local variables for |xy...@>=
  6752. @!extras:integer; {the number of additional nodes to make weights |>3|}
  6753. @!xw:-3..3; {the additional weight in extra nodes}
  6754. @!k:integer; {loop counter for inserting extra nodes}
  6755. @ At the beginning of this step, |move[m_spread]=sentinel|, because no
  6756. horizontal edges will extend to the right of column |m_max(cur_edges)|.
  6757. @<Adjust the header to reflect the new edges@>=
  6758. move[m_spread]:=0; j:=0;
  6759. while move[j]=sentinel do incr(j);
  6760. if j=m_spread then init_edges(cur_edges) {all edge weights are zero}
  6761. else  begin mm:=m_min(cur_edges);
  6762.   m_min(cur_edges):=n_min(cur_edges);
  6763.   m_max(cur_edges):=n_max(cur_edges)+1;
  6764.   m_offset(cur_edges):=zero_field;
  6765.   jj:=m_spread-1;
  6766.   while move[jj]=sentinel do decr(jj);
  6767.   n_min(cur_edges):=j+mm; n_max(cur_edges):=jj+mm; q:=cur_edges;
  6768.   repeat p:=get_node(row_node_size); link(q):=p; knil(p):=q;
  6769.   sorted(p):=move[j]; unsorted(p):=null; incr(j); q:=p;
  6770.   until j>jj;
  6771.   link(q):=cur_edges; knil(cur_edges):=q;
  6772.   n_pos(cur_edges):=n_max(cur_edges)+1; n_rover(cur_edges):=cur_edges;
  6773.   last_window_time(cur_edges):=0;
  6774.   end;
  6775. @ The values of |m_magic| and |n_magic| can be worked out by trying the
  6776. code above on a small example; if they work correctly in simple cases,
  6777. they should work in general.
  6778. @<Compute the magic offset values@>=
  6779. m_magic:=m_min(cur_edges)+m_offset(cur_edges)-zero_field;
  6780. n_magic:=8*n_max(cur_edges)+8+zero_w+min_halfword
  6781. @ Now let's look at the subroutine that merges the edges from a given
  6782. edge structure into |cur_edges|. The given edge structure loses all its
  6783. edges.
  6784. @p procedure merge_edges(@!h:pointer);
  6785. label done;
  6786. var @!p,@!q,@!r,@!pp,@!qq,@!rr:pointer; {list manipulation registers}
  6787. @!n:integer; {row number}
  6788. @!k:halfword; {key register that we compare to |info(q)|}
  6789. @!delta:integer; {change to the edge/weight data}
  6790. begin if link(h)<>h then
  6791.   begin if (m_min(h)<m_min(cur_edges))or(m_max(h)>m_max(cur_edges))or@|
  6792.     (n_min(h)<n_min(cur_edges))or(n_max(h)>n_max(cur_edges)) then
  6793.     edge_prep(m_min(h)-zero_field,m_max(h)-zero_field,
  6794.       n_min(h)-zero_field,n_max(h)-zero_field+1);
  6795.   if m_offset(h)<>m_offset(cur_edges) then
  6796.     @<Adjust the data of |h| to account for a difference of offsets@>;
  6797.   n:=n_min(cur_edges); p:=link(cur_edges); pp:=link(h);
  6798.   while n<n_min(h) do
  6799.     begin incr(n); p:=link(p);
  6800.     end;
  6801.   repeat @<Merge row |pp| into row |p|@>;
  6802.   pp:=link(pp); p:=link(p);
  6803.   until pp=h;
  6804.   end;
  6805. @ @<Adjust the data of |h| to account for a difference of offsets@>=
  6806. begin pp:=link(h); delta:=8*(m_offset(cur_edges)-m_offset(h));
  6807. repeat qq:=sorted(pp);
  6808. while qq<>sentinel do
  6809.   begin info(qq):=info(qq)+delta; qq:=link(qq);
  6810.   end;
  6811. qq:=unsorted(pp);
  6812. while qq>void do
  6813.   begin info(qq):=info(qq)+delta; qq:=link(qq);
  6814.   end;
  6815. pp:=link(pp);
  6816. until pp=h;
  6817. @ The |sorted| and |unsorted| lists are merged separately. After this
  6818. step, row~|pp| will have no edges remaining, since they will all have
  6819. been merged into row~|p|.
  6820. @<Merge row |pp|...@>=
  6821. qq:=unsorted(pp);
  6822. if qq>void then
  6823.   if unsorted(p)<=void then unsorted(p):=qq
  6824.   else  begin while link(qq)>void do qq:=link(qq);
  6825.     link(qq):=unsorted(p); unsorted(p):=unsorted(pp);
  6826.     end;
  6827. unsorted(pp):=null; qq:=sorted(pp);
  6828. if qq<>sentinel then
  6829.   begin if unsorted(p)=void then unsorted(p):=null;
  6830.   sorted(pp):=sentinel; r:=sorted_loc(p); q:=link(r); {|q=sorted(p)|}
  6831.   if q=sentinel then sorted(p):=qq
  6832.   else loop@+begin k:=info(qq);
  6833.     while k>info(q) do
  6834.       begin r:=q; q:=link(r);
  6835.       end;
  6836.     link(r):=qq; rr:=link(qq); link(qq):=q;
  6837.     if rr=sentinel then goto done;
  6838.     r:=qq; qq:=rr;
  6839.     end;
  6840.   end;
  6841. done:
  6842. @ The |total_weight| routine computes the total of all pixel weights
  6843. in a given edge structure. It's not difficult to prove that this is
  6844. the sum of $(-w)$ times $x$ taken over all edges,
  6845. where $w$ and~$x$ are the weight and $x$~coordinates stored in an edge.
  6846. It's not necessary to worry that this quantity will overflow the
  6847. size of an |integer| register, because it will be less than~$2^{31}$
  6848. unless the edge structure has more than 174,762 edges. However, we had
  6849. better not try to compute it as a |scaled| integer, because a total
  6850. weight of almost $12\times 2^{12}$ can be produced by only four edges.
  6851. @p function total_weight(@!h:pointer):integer; {|h| is an edge header}
  6852. var @!p,@!q:pointer; {variables that traverse the given structure}
  6853. @!n:integer; {accumulated total so far}
  6854. @!m:0..65535; {packed $x$ and $w$ values, including offsets}
  6855. begin n:=0; p:=link(h);
  6856. while p<>h do
  6857.   begin q:=sorted(p);
  6858.   while q<>sentinel do
  6859.     @<Add the contribution of node |q| to the total weight,
  6860.       and set |q:=link(q)|@>;
  6861.   q:=unsorted(p);
  6862.   while q>void do
  6863.     @<Add the contribution of node |q| to the total weight,
  6864.       and set |q:=link(q)|@>;
  6865.   p:=link(p);
  6866.   end;
  6867. total_weight:=n;
  6868. @ It's not necessary to add the offsets to the $x$ coordinates, because
  6869. an entire edge structure can be shifted without affecting its total weight.
  6870. Similarly, we don't need to subtract |zero_field|.
  6871. @<Add the contribution of node |q| to the total weight...@>=
  6872. begin m:=ho(info(q)); n:=n-((m mod 8)-zero_w)*(m div 8);
  6873. q:=link(q);
  6874. @ So far we've done lots of things to edge structures assuming that
  6875. edges are actually present, but we haven't seen how edges get created
  6876. in the first place. Let's turn now to the problem of generating new edges.
  6877. \MF\ will display new edges as they are being computed, if |tracing_edges|
  6878. is positive. In order to keep such data reasonably compact, only the
  6879. points at which the path makes a $90^\circ$ or $180^\circ$ turn are listed.
  6880. The tracing algorithm must remember some past history in order to suppress
  6881. unnecessary data. Three variables |trace_x|, |trace_y|, and |trace_yy|
  6882. provide this history: The last coordinates printed were |(trace_x,trace_y)|,
  6883. and the previous edge traced ended at |(trace_x,trace_yy)|. Before anything
  6884. at all has been traced, |trace_x=-4096|.
  6885. @<Glob...@>=
  6886. @!trace_x:integer; {$x$~coordinate most recently shown in a trace}
  6887. @!trace_y:integer; {$y$~coordinate most recently shown in a trace}
  6888. @!trace_yy:integer; {$y$~coordinate most recently encountered}
  6889. @ Edge tracing is initiated by the |begin_edge_tracing| routine,
  6890. continued by the |trace_a_corner| routine, and terminated by the
  6891. |end_edge_tracing| routine.
  6892. @p procedure begin_edge_tracing;
  6893. begin print_diagnostic("Tracing edges","",true);
  6894. print(" (weight "); print_int(cur_wt); print_char(")"); trace_x:=-4096;
  6895. procedure trace_a_corner;
  6896. begin if file_offset>max_print_line-13 then print_nl("");
  6897. print_char("("); print_int(trace_x); print_char(","); print_int(trace_yy);
  6898. print_char(")"); trace_y:=trace_yy;
  6899. procedure end_edge_tracing;
  6900. begin if trace_x=-4096 then print_nl("(No new edges added.)")
  6901. @.No new edges added@>
  6902. else  begin trace_a_corner; print_char(".");
  6903.   end;
  6904. end_diagnostic(true);
  6905. @ Just after a new edge weight has been put into the |info| field of
  6906. node~|r|, in row~|n|, the following routine continues an ongoing trace.
  6907. @p procedure trace_new_edge(@!r:pointer;@!n:integer);
  6908. var @!d:integer; {temporary data register}
  6909. @!w:-3..3; {weight associated with an edge transition}
  6910. @!m,@!n0,@!n1:integer; {column and row numbers}
  6911. begin d:=ho(info(r)); w:=(d mod 8)-zero_w; m:=(d div 8)-m_offset(cur_edges);
  6912. if w=cur_wt then
  6913.   begin n0:=n+1; n1:=n;
  6914.   end
  6915. else  begin n0:=n; n1:=n+1;
  6916.   end; {the edges run from |(m,n0)| to |(m,n1)|}
  6917. if m<>trace_x then
  6918.   begin if trace_x=-4096 then
  6919.     begin print_nl(""); trace_yy:=n0;
  6920.     end
  6921.   else if trace_yy<>n0 then print_char("?") {shouldn't happen}
  6922.   else trace_a_corner;
  6923.   trace_x:=m; trace_a_corner;
  6924.   end
  6925. else  begin if n0<>trace_yy then print_char("!"); {shouldn't happen}
  6926.   if ((n0<n1)and(trace_y>trace_yy))or((n0>n1)and(trace_y<trace_yy)) then
  6927.     trace_a_corner;
  6928.   end;
  6929. trace_yy:=n1;
  6930. @ One way to put new edge weights into an edge structure is to use the
  6931. following routine, which simply draws a straight line from |(x0,y0)| to
  6932. |(x1,y1)|. More precisely, it introduces weights for the edges of the
  6933. discrete path $\bigl(\lfloor t[x_0,x_1]+{1\over2}+\epsilon\rfloor,
  6934. \lfloor t[y_0,y_1]+{1\over2}+\epsilon\delta\rfloor\bigr)$,
  6935. as $t$ varies from 0 to~1, where $\epsilon$ and $\delta$ are extremely small
  6936. positive numbers.
  6937. The structure header is assumed to be |cur_edges|; downward edge weights
  6938. will be |cur_wt|, while upward ones will be |-cur_wt|.
  6939. Of course, this subroutine will be called only in connection with others
  6940. that eventually draw a complete cycle, so that the sum of the edge weights
  6941. in each row will be zero whenever the row is displayed.
  6942. @p procedure line_edges(@!x0,@!y0,@!x1,@!y1:scaled);
  6943. label done,done1;
  6944. var @!m0,@!n0,@!m1,@!n1:integer; {rounded and unscaled coordinates}
  6945. @!delx,@!dely:scaled; {the coordinate differences of the line}
  6946. @!yt:scaled; {smallest |y| coordinate that rounds the same as |y0|}
  6947. @!tx:scaled; {tentative change in |x|}
  6948. @!p,@!r:pointer; {list manipulation registers}
  6949. @!base:integer; {amount added to edge-and-weight data}
  6950. @!n:integer; {current row number}
  6951. begin n0:=round_unscaled(y0);
  6952. n1:=round_unscaled(y1);
  6953. if n0<>n1 then
  6954.   begin m0:=round_unscaled(x0); m1:=round_unscaled(x1);
  6955.   delx:=x1-x0; dely:=y1-y0;
  6956.   yt:=n0*unity-half_unit; y0:=y0-yt; y1:=y1-yt;
  6957.   if n0<n1 then @<Insert upward edges for a line@>
  6958.   else @<Insert downward edges for a line@>;
  6959.   n_rover(cur_edges):=p; n_pos(cur_edges):=n+zero_field;
  6960.   end;
  6961. @ Here we are careful to cancel any effect of rounding error.
  6962. @<Insert upward edges for a line@>=
  6963. begin base:=8*m_offset(cur_edges)+min_halfword+zero_w-cur_wt;
  6964. if m0<=m1 then edge_prep(m0,m1,n0,n1)@+else edge_prep(m1,m0,n0,n1);
  6965. @<Move to row |n0|, pointed to by |p|@>;
  6966. y0:=unity-y0;
  6967. loop@+  begin r:=get_avail; link(r):=unsorted(p); unsorted(p):=r;@/
  6968.   tx:=take_fraction(delx,make_fraction(y0,dely));
  6969.   if ab_vs_cd(delx,y0,dely,tx)<0 then decr(tx);
  6970.     {now $|tx|=\lfloor|y0|\cdot|delx|/|dely|\rfloor$}
  6971.   info(r):=8*round_unscaled(x0+tx)+base;@/
  6972.   y1:=y1-unity;
  6973.   if internal[tracing_edges]>0 then trace_new_edge(r,n);
  6974.   if y1<unity then goto done;
  6975.   p:=link(p); y0:=y0+unity; incr(n);
  6976.   end;
  6977. done: end
  6978. @ @<Insert downward edges for a line@>=
  6979. begin base:=8*m_offset(cur_edges)+min_halfword+zero_w+cur_wt;
  6980. if m0<=m1 then edge_prep(m0,m1,n1,n0)@+else edge_prep(m1,m0,n1,n0);
  6981. decr(n0); @<Move to row |n0|, pointed to by |p|@>;
  6982. loop@+  begin r:=get_avail; link(r):=unsorted(p); unsorted(p):=r;@/
  6983.   tx:=take_fraction(delx,make_fraction(y0,dely));
  6984.   if ab_vs_cd(delx,y0,dely,tx)<0 then incr(tx);
  6985.     {now $|tx|=\lceil|y0|\cdot|delx|/|dely|\rceil$, since |dely<0|}
  6986.   info(r):=8*round_unscaled(x0-tx)+base;@/
  6987.   y1:=y1+unity;
  6988.   if internal[tracing_edges]>0 then trace_new_edge(r,n);
  6989.   if y1>=0 then goto done1;
  6990.   p:=knil(p); y0:=y0+unity; decr(n);
  6991.   end;
  6992. done1: end
  6993. @ @<Move to row |n0|, pointed to by |p|@>=
  6994. n:=n_pos(cur_edges)-zero_field; p:=n_rover(cur_edges);
  6995. if n<>n0 then
  6996.   if n<n0 then
  6997.     repeat incr(n); p:=link(p);
  6998.     until n=n0
  6999.   else  repeat decr(n); p:=knil(p);
  7000.     until n=n0
  7001. @ \MF\ inserts most of its edges into edge structures via the
  7002. |move_to_edges| subroutine, which uses the data stored in the |move| array
  7003. to specify a sequence of ``rook moves.'' The starting point |(m0,n0)|
  7004. and finishing point |(m1,n1)| of these moves, as seen from the standpoint
  7005. of the first octant, are supplied as parameters; the moves should, however,
  7006. be rotated into a given octant.  (We're going to study octant
  7007. transformations in great detail later; the reader may wish to come back to
  7008. this part of the program after mastering the mysteries of octants.)
  7009. The rook moves themselves are defined as follows, from a |first_octant|
  7010. point of view: ``Go right |move[k]| steps, then go up one, for |0<=k<n1-n0|;
  7011. then go right |move[n1-n0]| steps and stop.'' The sum of |move[k]|
  7012. for |0<=k<=n1-n0| will be equal to |m1-m0|.
  7013. As in the |line_edges| routine, we use |+cur_wt| as the weight of
  7014. all downward edges and |-cur_wt| as the weight of all upward edges,
  7015. after the moves have been rotated to the proper octant direction.
  7016. There are two main cases to consider: \\{fast\_case} is for moves that
  7017. travel in the direction of octants 1, 4, 5, and~8, while \\{slow\_case}
  7018. is for moves that travel toward octants 2, 3, 6, and~7. The latter directions
  7019. are comparatively cumbersome because they generate more upward or downward
  7020. edges; a curve that travels horizontally doesn't produce any edges at all,
  7021. but a curve that travels vertically touches lots of rows.
  7022. @d fast_case_up=60 {for octants 1 and 4}
  7023. @d fast_case_down=61 {for octants 5 and 8}
  7024. @d slow_case_up=62 {for octants 2 and 3}
  7025. @d slow_case_down=63 {for octants 6 and 7}
  7026. @p procedure move_to_edges(@!m0,@!n0,@!m1,@!n1:integer);
  7027. label fast_case_up,fast_case_down,slow_case_up,slow_case_down,done;
  7028. var @!delta:0..move_size; {extent of |move| data}
  7029. @!k:0..move_size; {index into |move|}
  7030. @!p,@!r:pointer; {list manipulation registers}
  7031. @!dx:integer; {change in edge-weight |info| when |x| changes by 1}
  7032. @!edge_and_weight:integer; {|info| to insert}
  7033. @!j:integer; {number of consecutive vertical moves}
  7034. @!n:integer; {the current row pointed to by |p|}
  7035. debug @!sum:integer;@+gubed@;@/
  7036. begin delta:=n1-n0;
  7037. debug sum:=move[0]; for k:=1 to delta do sum:=sum+abs(move[k]);
  7038. if sum<>m1-m0 then confusion("0");@+gubed@;@/
  7039. @:this can't happen 0}{\quad 0@>
  7040. @<Prepare for and switch to the appropriate case, based on |octant|@>;
  7041. fast_case_up:@<Add edges for first or fourth octants, then |goto done|@>;
  7042. fast_case_down:@<Add edges for fifth or eighth octants, then |goto done|@>;
  7043. slow_case_up:@<Add edges for second or third octants, then |goto done|@>;
  7044. slow_case_down:@<Add edges for sixth or seventh octants, then |goto done|@>;
  7045. done: n_pos(cur_edges):=n+zero_field; n_rover(cur_edges):=p;
  7046. @ The current octant code appears in a global variable. If, for example,
  7047. we have |octant=third_octant|, it means that a curve traveling in a north to
  7048. north-westerly direction has been rotated for the purposes of internal
  7049. calculations so that the |move| data travels in an east to north-easterly
  7050. direction. We want to unrotate as we update the edge structure.
  7051. @<Glob...@>=
  7052. @!octant:first_octant..sixth_octant; {the current octant of interest}
  7053. @ @<Prepare for and switch to the appropriate case, based on |octant|@>=
  7054. case octant of
  7055. first_octant:begin dx:=8; edge_prep(m0,m1,n0,n1); goto fast_case_up;
  7056.   end;
  7057. second_octant:begin dx:=8; edge_prep(n0,n1,m0,m1); goto slow_case_up;
  7058.   end;
  7059. third_octant:begin dx:=-8; edge_prep(-n1,-n0,m0,m1); negate(n0);
  7060.   goto slow_case_up;
  7061.   end;
  7062. fourth_octant:begin dx:=-8; edge_prep(-m1,-m0,n0,n1); negate(m0);
  7063.   goto fast_case_up;
  7064.   end;
  7065. fifth_octant:begin dx:=-8; edge_prep(-m1,-m0,-n1,-n0); negate(m0);
  7066.   goto fast_case_down;
  7067.   end;
  7068. sixth_octant:begin dx:=-8; edge_prep(-n1,-n0,-m1,-m0); negate(n0);
  7069.   goto slow_case_down;
  7070.   end;
  7071. seventh_octant:begin dx:=8; edge_prep(n0,n1,-m1,-m0); goto slow_case_down;
  7072.   end;
  7073. eighth_octant:begin dx:=8; edge_prep(m0,m1,-n1,-n0); goto fast_case_down;
  7074.   end;
  7075. end; {there are only eight octants}
  7076. @ @<Add edges for first or fourth octants, then |goto done|@>=
  7077. @<Move to row |n0|, pointed to by |p|@>;
  7078. if delta>0 then
  7079.   begin k:=0;
  7080.   edge_and_weight:=8*(m0+m_offset(cur_edges))+min_halfword+zero_w-cur_wt;
  7081.   repeat edge_and_weight:=edge_and_weight+dx*move[k];
  7082.   fast_get_avail(r); link(r):=unsorted(p); info(r):=edge_and_weight;
  7083.   if internal[tracing_edges]>0 then trace_new_edge(r,n);
  7084.   unsorted(p):=r; p:=link(p); incr(k); incr(n);
  7085.   until k=delta;
  7086.   end;
  7087. goto done
  7088. @ @<Add edges for fifth or eighth octants, then |goto done|@>=
  7089. n0:=-n0-1; @<Move to row |n0|, pointed to by |p|@>;
  7090. if delta>0 then
  7091.   begin k:=0;
  7092.   edge_and_weight:=8*(m0+m_offset(cur_edges))+min_halfword+zero_w+cur_wt;
  7093.   repeat edge_and_weight:=edge_and_weight+dx*move[k];
  7094.   fast_get_avail(r); link(r):=unsorted(p); info(r):=edge_and_weight;
  7095.   if internal[tracing_edges]>0 then trace_new_edge(r,n);
  7096.   unsorted(p):=r; p:=knil(p); incr(k); decr(n);
  7097.   until k=delta;
  7098.   end;
  7099. goto done
  7100. @ @<Add edges for second or third octants, then |goto done|@>=
  7101. edge_and_weight:=8*(n0+m_offset(cur_edges))+min_halfword+zero_w-cur_wt;
  7102. n0:=m0; k:=0; @<Move to row |n0|, pointed to by |p|@>;
  7103. repeat j:=move[k];
  7104. while j>0 do
  7105.   begin fast_get_avail(r); link(r):=unsorted(p); info(r):=edge_and_weight;
  7106.   if internal[tracing_edges]>0 then trace_new_edge(r,n);
  7107.   unsorted(p):=r; p:=link(p); decr(j); incr(n);
  7108.   end;
  7109. edge_and_weight:=edge_and_weight+dx; incr(k);
  7110. until k>delta;
  7111. goto done
  7112. @ @<Add edges for sixth or seventh octants, then |goto done|@>=
  7113. edge_and_weight:=8*(n0+m_offset(cur_edges))+min_halfword+zero_w+cur_wt;
  7114. n0:=-m0-1; k:=0; @<Move to row |n0|, pointed to by |p|@>;
  7115. repeat j:=move[k];
  7116. while j>0 do
  7117.   begin fast_get_avail(r); link(r):=unsorted(p); info(r):=edge_and_weight;
  7118.   if internal[tracing_edges]>0 then trace_new_edge(r,n);
  7119.   unsorted(p):=r; p:=knil(p); decr(j); decr(n);
  7120.   end;
  7121. edge_and_weight:=edge_and_weight+dx; incr(k);
  7122. until k>delta;
  7123. goto done
  7124. @ All the hard work of building an edge structure is undone by the following
  7125. subroutine.
  7126. @<Declare the recycling subroutines@>=
  7127. procedure toss_edges(@!h:pointer);
  7128. var @!p,@!q:pointer; {for list manipulation}
  7129. begin q:=link(h);
  7130. while q<>h do
  7131.   begin flush_list(sorted(q));
  7132.   if unsorted(q)>void then flush_list(unsorted(q));
  7133.   p:=q; q:=link(q); free_node(p,row_node_size);
  7134.   end;
  7135. free_node(h,edge_header_size);
  7136. @* \[21] Subdivision into octants.
  7137. When \MF\ digitizes a path, it reduces the problem to the special
  7138. case of paths that travel in ``first octant'' directions; i.e.,
  7139. each cubic $z(t)=\bigl(x(t),y(t)\bigr)$ being digitized will have the property
  7140. that $0\L y'(t)\L x'(t)$. This assumption makes digitizing simpler
  7141. and faster than if the direction of motion has to be tested repeatedly.
  7142. When $z(t)$ is cubic, $x'(t)$ and $y'(t)$ are quadratic, hence the four
  7143. polynomials $x'(t)$, $y'(t)$, $x'(t)-y'(t)$, and $x'(t)+y'(t)$ cross
  7144. through~0 at most twice each. If we subdivide the given cubic at these
  7145. places, we get at most nine subintervals in each of which
  7146. $x'(t)$, $y'(t)$, $x'(t)-y'(t)$, and $x'(t)+y'(t)$ all have a constant
  7147. sign. The curve can be transformed in each of these subintervals so that
  7148. it travels entirely in first octant directions, if we reflect $x\swap-x$,
  7149. $y\swap-y$, and/or $x\swap y$ as necessary. (Incidentally, it can be
  7150. shown that a cubic such that $x'(t)=16(2t-1)^2+2(2t-1)-1$ and
  7151. $y'(t)=8(2t-1)^2+4(2t-1)$ does indeed split into nine subintervals.)
  7152. @ The transformation that rotates coordinates, so that first octant motion
  7153. can be assumed, is defined by the |skew| subroutine, which sets global
  7154. variables |cur_x| and |cur_y| to the values that are appropriate in a
  7155. given octant.  (Octants are encoded as they were in the |n_arg| subroutine.)
  7156. This transformation is ``skewed'' by replacing |(x,y)| by |(x-y,y)|,
  7157. once first octant motion has been established. It turns out that
  7158. skewed coordinates are somewhat better to work with when curves are
  7159. actually digitized.
  7160. @d set_two_end(#)==cur_y:=#;@+end
  7161. @d set_two(#)==begin cur_x:=#; set_two_end
  7162. @p procedure skew(@!x,@!y:scaled;@!octant:small_number);
  7163. begin case octant of
  7164. first_octant: set_two(x-y)(y);
  7165. second_octant: set_two(y-x)(x);
  7166. third_octant: set_two(y+x)(-x);
  7167. fourth_octant: set_two(-x-y)(y);
  7168. fifth_octant: set_two(-x+y)(-y);
  7169. sixth_octant: set_two(-y+x)(-x);
  7170. seventh_octant: set_two(-y-x)(x);
  7171. eighth_octant: set_two(x+y)(-y);
  7172. end; {there are no other cases}
  7173. @ Conversely, the following subroutine sets |cur_x| and
  7174. |cur_y| to the original coordinate values of a point, given an octant
  7175. code and the point's coordinates |(x,y)| after they have been mapped into
  7176. the first octant and skewed.
  7177. @<Declare subroutines for printing expressions@>=
  7178. procedure unskew(@!x,@!y:scaled;@!octant:small_number);
  7179. begin case octant of
  7180. first_octant: set_two(x+y)(y);
  7181. second_octant: set_two(y)(x+y);
  7182. third_octant: set_two(-y)(x+y);
  7183. fourth_octant: set_two(-x-y)(y);
  7184. fifth_octant: set_two(-x-y)(-y);
  7185. sixth_octant: set_two(-y)(-x-y);
  7186. seventh_octant: set_two(y)(-x-y);
  7187. eighth_octant: set_two(x+y)(-y);
  7188. end; {there are no other cases}
  7189. @ @<Glob...@>=
  7190. @!cur_x,@!cur_y:scaled;
  7191.   {outputs of |rotate|, |unrotate|, and a few other routines}
  7192. @ The conversion to skewed and rotated coordinates takes place in
  7193. stages, and at one point in the transformation we will have negated the
  7194. $x$ and/or $y$ coordinates so as to make curves travel in the first
  7195. {\sl quadrant}. At this point the relevant ``octant'' code will be
  7196. either |first_octant| (when no transformation has been done),
  7197. or |fourth_octant=first_octant+negate_x| (when $x$ has been negated),
  7198. or |fifth_octant=first_octant+negate_x+negate_y| (when both have been
  7199. negated), or |eighth_octant=first_octant+negate_y| (when $y$ has been
  7200. negated). The |abnegate| routine is sometimes needed to convert
  7201. from one of these transformations to another.
  7202. @p procedure abnegate(@!x,@!y:scaled;
  7203.   @!octant_before,@!octant_after:small_number);
  7204. begin if odd(octant_before)=odd(octant_after) then cur_x:=x
  7205.   else cur_x:=-x;
  7206. if (octant_before>negate_y)=(octant_after>negate_y) then cur_y:=y
  7207.   else cur_y:=-y;
  7208. @ Now here's a subroutine that's handy for subdivision: Given a
  7209. quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function
  7210. returns the unique |fraction| value |t| between 0 and~1 at which
  7211. $B(a,b,c;t)$ changes from positive to negative, or returns
  7212. |t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$
  7213. is already negative at |t=0|), |crossing_point| returns the value zero.
  7214. @d no_crossing==begin crossing_point:=fraction_one+1; return;
  7215.   end
  7216. @d one_crossing==begin crossing_point:=fraction_one; return;
  7217.   end
  7218. @d zero_crossing==begin crossing_point:=0; return;
  7219.   end
  7220. @p function crossing_point(@!a,@!b,@!c:integer):fraction;
  7221. label exit;
  7222. var @!d:integer; {recursive counter}
  7223. @!x,@!xx,@!x0,@!x1,@!x2:integer; {temporary registers for bisection}
  7224. begin if a<0 then zero_crossing;
  7225. if c>=0 then
  7226.   begin if b>=0 then
  7227.     if c>0 then no_crossing
  7228.     else if (a=0)and(b=0) then no_crossing
  7229.     else one_crossing;
  7230.   if a=0 then zero_crossing;
  7231.   end
  7232. else if a=0 then if b<=0 then zero_crossing;
  7233. @<Use bisection to find the crossing point, if one exists@>;
  7234. exit:end;
  7235. @ The general bisection method is quite simple when $n=2$, hence
  7236. |crossing_point| does not take much time. At each stage in the
  7237. recursion we have a subinterval defined by |l| and~|j| such that
  7238. $B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on
  7239. the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$.
  7240. It is convenient for purposes of calculation to combine the values
  7241. of |l| and~|j| in a single variable $d=2^l+j$, because the operation
  7242. of bisection then corresponds simply to doubling $d$ and possibly
  7243. adding~1. Furthermore it proves to be convenient to modify
  7244. our previous conventions for bisection slightly, maintaining the
  7245. variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$.
  7246. With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are
  7247. equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$.
  7248. The following code maintains the invariant relations
  7249. $0\L|x0|<\max(|x1|,|x1|+|x2|)$,
  7250. $\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$;
  7251. it has been constructed in such a way that no arithmetic overflow
  7252. will occur if the inputs satisfy
  7253. $a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$.
  7254. @<Use bisection to find the crossing point...@>=
  7255. d:=1; x0:=a; x1:=a-b; x2:=b-c;
  7256. repeat x:=half(x1+x2);
  7257. if x1-x0>x0 then
  7258.   begin x2:=x; double(x0); double(d);
  7259.   end
  7260. else  begin xx:=x1+x-x0;
  7261.   if xx>x0 then
  7262.     begin x2:=x; double(x0); double(d);
  7263.     end
  7264.   else  begin x0:=x0-xx;
  7265.     if x<=x0 then if x+x2<=x0 then no_crossing;
  7266.     x1:=x; d:=d+d+1;
  7267.     end;
  7268.   end;
  7269. until d>=fraction_one;
  7270. crossing_point:=d-fraction_one
  7271. @ Octant subdivision is applied only to cycles, i.e., to closed paths.
  7272. A ``cycle spec'' is a data structure that contains specifications of
  7273. @!@^cycle spec@>
  7274. cubic curves and octant mappings for the cycle that has been subdivided
  7275. into segments belonging to single octants. It is composed entirely of
  7276. knot nodes, similar to those in the representation of paths; but the
  7277. |explicit| type indications have been replaced by positive numbers
  7278. that give further information. Additional |endpoint| data is also
  7279. inserted at the octant boundaries.
  7280. Recall that a cubic polynomial is represented by four control points
  7281. that appear in adjacent nodes |p| and~|q| of a knot list. The |x|~coordinates
  7282. are |x_coord(p)|, |right_x(p)|, |left_x(q)|, and |x_coord(q)|; the
  7283. |y|~coordinates are similar. We shall call this ``the cubic following~|p|''
  7284. or ``the cubic between |p| and~|q|'' or ``the cubic preceding~|q|.''
  7285. Cycle specs are circular lists of cubic curves mixed with octant
  7286. boundaries. Like cubics, the octant boundaries are represented in
  7287. consecutive knot nodes |p| and~|q|. In such cases |right_type(p)=
  7288. left_type(q)=endpoint|, and the fields |right_x(p)|, |right_y(p)|,
  7289. |left_x(q)|, and |left_y(q)| are replaced by other fields called
  7290. |right_octant(p)|, |right_transition(p)|, |left_octant(q)|, and
  7291. |left_transition(q)|, respectively. For example, when the curve direction
  7292. moves from the third octant to the fourth octant, the boundary nodes say
  7293. |right_octant(p)=third_octant|, |left_octant(q)=fourth_octant|,
  7294. and |right_transition(p)=left_transition(q)=diagonal|. A |diagonal|
  7295. transition occurs when moving between octants 1~\AM~2, 3~\AM~4, 5~\AM~6, or
  7296. 7~\AM~8; an |axis| transition occurs when moving between octants 8~\AM~1,
  7297. 2~\AM~3, 4~\AM~5, 6~\AM~7. (Such transition information is redundant
  7298. but convenient.) Fields |x_coord(p)| and |y_coord(p)| will contain
  7299. coordinates of the transition point after rotation from third octant
  7300. to first octant; i.e., if the true coordinates are $(x,y)$, the
  7301. coordinates $(y,\bar x)$ will appear in node~|p|. Similarly, a fourth-octant
  7302. transformation will have been applied after the transition, so
  7303. we will have |x_coord(q)=@t$\bar x$@>| and |y_coord(q)=y|.
  7304. The cubic between |p| and |q| will contain positive numbers in the
  7305. fields |right_type(p)| and |left_type(q)|; this makes cubics
  7306. distinguishable from octant boundaries, because |endpoint=0|.
  7307. The value of |right_type(p)| will be the current octant code,
  7308. during the time that cycle specs are being constructed; it will
  7309. refer later to a pen offset position, if the envelope of a cycle is
  7310. being computed. A cubic that comes from some subinterval of the $k$th
  7311. step in the original cyclic path will have |left_type(q)=k|.
  7312. @d right_octant==right_x {the octant code before a transition}
  7313. @d left_octant==left_x {the octant after a transition}
  7314. @d right_transition==right_y {the type of transition}
  7315. @d left_transition==left_y {ditto, either |axis| or |diagonal|}
  7316. @d axis=0 {a transition across the $x'$- or $y'$-axis}
  7317. @d diagonal=1 {a transition where $y'=\pm x'$}
  7318. @ Here's a routine that prints a cycle spec in symbolic form, so that it
  7319. is possible to see what subdivision has been made.  The point coordinates
  7320. are converted back from \MF's internal ``rotated'' form to the external
  7321. ``true'' form. The global variable~|cur_spec| should point to a knot just
  7322. after the beginning of an octant boundary, i.e., such that
  7323. |left_type(cur_spec)=endpoint|.
  7324. @d print_two_true(#)==unskew(#,octant); print_two(cur_x,cur_y)
  7325. @p procedure print_spec(@!s:str_number);
  7326. label not_found,done;
  7327. var @!p,@!q:pointer; {for list traversal}
  7328. @!octant:small_number; {the current octant code}
  7329. begin print_diagnostic("Cycle spec",s,true);
  7330. @.Cycle spec at line...@>
  7331. p:=cur_spec; octant:=left_octant(p); print_ln;
  7332. print_two_true(x_coord(cur_spec),y_coord(cur_spec));
  7333. print(" % beginning in octant `");
  7334. loop@+  begin print(octant_dir[octant]); print_char("'");
  7335.   loop@+  begin q:=link(p);
  7336.     if right_type(p)=endpoint then goto not_found;
  7337.     @<Print the cubic between |p| and |q|@>;
  7338.     p:=q;
  7339.     end;
  7340. not_found: if q=cur_spec then goto done;
  7341.   p:=q; octant:=left_octant(p); print_nl("% entering octant `");
  7342.   end;
  7343. @.entering the nth octant@>
  7344. done: print_nl(" & cycle"); end_diagnostic(true);
  7345. @ Symbolic octant direction names are kept in the |octant_dir| array.
  7346. @<Glob...@>=
  7347. @!octant_dir:array[first_octant..sixth_octant] of str_number;
  7348. @ @<Set init...@>=
  7349. octant_dir[first_octant]:="ENE";
  7350. octant_dir[second_octant]:="NNE";
  7351. octant_dir[third_octant]:="NNW";
  7352. octant_dir[fourth_octant]:="WNW";
  7353. octant_dir[fifth_octant]:="WSW";
  7354. octant_dir[sixth_octant]:="SSW";
  7355. octant_dir[seventh_octant]:="SSE";
  7356. octant_dir[eighth_octant]:="ESE";
  7357. @ @<Print the cubic between...@>=
  7358. begin print_nl("   ..controls ");
  7359. print_two_true(right_x(p),right_y(p));
  7360. print(" and ");
  7361. print_two_true(left_x(q),left_y(q));
  7362. print_nl(" ..");
  7363. print_two_true(x_coord(q),y_coord(q));
  7364. print(" % segment "); print_int(left_type(q)-1);
  7365. @ A much more compact version of a spec is printed to help users identify
  7366. ``strange paths.''
  7367. @p procedure print_strange(@!s:str_number);
  7368. var @!p:pointer; {for list traversal}
  7369. @!f:pointer; {starting point in the cycle}
  7370. @!q:pointer; {octant boundary to be printed}
  7371. @!t:integer; {segment number, plus 1}
  7372. begin if interaction=error_stop_mode then wake_up_terminal;
  7373. print_nl(">");
  7374. @.>\relax@>
  7375. @<Find the starting point, |f|@>;
  7376. @<Determine the octant boundary |q| that precedes |f|@>;
  7377. t:=0;
  7378. repeat if left_type(p)<>endpoint then
  7379.   begin if left_type(p)<>t then
  7380.     begin t:=left_type(p); print_char(" "); print_int(t-1);
  7381.     end;
  7382.   if q<>null then
  7383.     begin @<Print the turns, if any, that start at |q|, and advance |q|@>;
  7384.     print_char(" "); print(octant_dir[left_octant(q)]); q:=null;
  7385.     end;
  7386.   end
  7387. else if q=null then q:=p;
  7388. p:=link(p);
  7389. until p=f;
  7390. print_char(" "); print_int(left_type(p)-1);
  7391. if q<>null then @<Print the turns...@>;
  7392. print_err(s);
  7393. @ If the segment numbers on the cycle are $t_1$, $t_2$, \dots, $t_m$,
  7394. we have $t_{k-1}\L t_k$ except for at most one value of~$k$. If there are
  7395. no exceptions, $f$ will point to $t_1$; otherwise it will point to the
  7396. exceptional~$t_k$.
  7397. There is at least one segment number (i.e., we always have $m>0$), because
  7398. |print_strange| is never called upon to display an entirely ``dead'' cycle.
  7399. @<Find the starting point, |f|@>=
  7400. p:=cur_spec; t:=max_quarterword+1;
  7401. repeat p:=link(p);
  7402. if left_type(p)<>endpoint then
  7403.   begin if left_type(p)<t then f:=p;
  7404.   t:=left_type(p);
  7405.   end;
  7406. until p=cur_spec
  7407. @ @<Determine the octant boundary...@>=
  7408. p:=cur_spec; q:=p;
  7409. repeat p:=link(p);
  7410. if left_type(p)=endpoint then q:=p;
  7411. until p=f
  7412. @ When two octant boundaries are adjacent, the path is simply changing direction
  7413. without moving. Such octant directions are shown in parentheses.
  7414. @<Print the turns...@>=
  7415. if left_type(link(q))=endpoint then
  7416.   begin print(" ("); print(octant_dir[left_octant(q)]); q:=link(q);
  7417.   while left_type(link(q))=endpoint do
  7418.     begin print_char(" "); print(octant_dir[left_octant(q)]); q:=link(q);
  7419.     end;
  7420.   print_char(")");
  7421.   end
  7422. @ The |make_spec| routine is what subdivides paths into octants:
  7423. Given a pointer |cur_spec| to a cyclic path, |make_spec| mungs the path data
  7424. and returns a pointer to the corresponding cyclic spec.
  7425. All ``dead'' cubics (i.e., cubics that don't move at all from
  7426. their starting points) will have been removed from the result.
  7427. @!@^dead cubics@>
  7428. The idea of |make_spec| is fairly simple: Each cubic is first
  7429. subdivided, if necessary, into pieces belonging to single octants;
  7430. then the octant boundaries are inserted. But some of the details of
  7431. this transformation are not quite obvious.
  7432. If |autorounding>0|, the path will be adjusted so that critical tangent
  7433. directions occur at ``good'' points with respect to the pen called |cur_pen|.
  7434. The resulting spec will have all |x| and |y| coordinates at most
  7435. $2^{28}-|half_unit|-1-|safety_margin|$ in absolute value.  The pointer
  7436. that is returned will start some octant, as required by |print_spec|.
  7437. @p @t\4@>@<Declare subroutines needed by |make_spec|@>@;
  7438. function make_spec(@!h:pointer;
  7439.   @!safety_margin:scaled;@!tracing:integer):pointer;
  7440.   {converts a path to a cycle spec}
  7441. label continue,done;
  7442. var @!p,@!q,@!r,@!s:pointer; {for traversing the lists}
  7443. @!k:integer; {serial number of path segment, or octant code}
  7444. @!chopped:boolean; {have we truncated any of the data?}
  7445. @<Other local variables for |make_spec|@>@;
  7446. begin cur_spec:=h;
  7447. if tracing>0 then
  7448.   print_path(cur_spec,", before subdivision into octants",true);
  7449. max_allowed:=fraction_one-half_unit-1-safety_margin;
  7450. @<Truncate the values of all coordinates that exceed |max_allowed|, and stamp
  7451.   segment numbers in each |left_type| field@>;
  7452. quadrant_subdivide; {subdivide each cubic into pieces belonging to quadrants}
  7453. if internal[autorounding]>0 then xy_round;
  7454. octant_subdivide; {complete the subdivision}
  7455. if internal[autorounding]>unity then diag_round;
  7456. @<Remove dead cubics@>;
  7457. @<Insert octant boundaries and compute the turning number@>;
  7458. while left_type(cur_spec)<>endpoint do cur_spec:=link(cur_spec);
  7459. if tracing>0 then
  7460.   if internal[autorounding]<=0 then print_spec(", after subdivision")
  7461.   else if internal[autorounding]>unity then
  7462.     print_spec(", after subdivision and double autorounding")
  7463.   else print_spec(", after subdivision and autorounding");
  7464. make_spec:=cur_spec;
  7465. @ The |make_spec| routine has an interesting side effect, namely to set
  7466. the global variable |turning_number| to the number of times the tangent
  7467. vector of the given cyclic path winds around the origin.
  7468. Another global variable |cur_spec| points to the specification as it is
  7469. being made, since several subroutines must go to work on it.
  7470. And there are two global variables that affect the rounding
  7471. decisions, as we'll see later; they are called |cur_pen| and |cur_path_type|.
  7472. The latter will be |double_path_code| if |make_spec| is being
  7473. applied to a double path.
  7474. @d double_path_code=0 {command modifier for `\&{doublepath}'}
  7475. @d contour_code=1 {command modifier for `\&{contour}'}
  7476. @d also_code=2 {command modifier for `\&{also}'}
  7477. @<Glob...@>=
  7478. @!cur_spec:pointer; {the principal output of |make_spec|}
  7479. @!turning_number:integer; {another output of |make_spec|}
  7480. @!cur_pen:pointer; {an implicit input of |make_spec|, used in autorounding}
  7481. @!cur_path_type:double_path_code..contour_code; {likewise}
  7482. @!max_allowed:scaled; {coordinates must be at most this big}
  7483. @ First we do a simple preprocessing step. The segment numbers inserted
  7484. here will propagate to all descendants of cubics that are split into
  7485. subintervals. These numbers must be nonzero, but otherwise they are
  7486. present merely for diagnostic purposes. The cubic from |p| to~|q|
  7487. that represents ``time interval'' |(t-1)..t| usually has |right_type(q)=t|,
  7488. except when |t| is too large to be stored in a quarterword.
  7489. @d procrustes(#)==if abs(#)>max_allowed then
  7490.     begin chopped:=true;
  7491.     if #>0 then #:=max_allowed@+else #:=-max_allowed;
  7492.     end
  7493. @<Truncate the values of all coordinates that exceed...@>=
  7494. p:=cur_spec; k:=1; chopped:=false;
  7495. repeat procrustes(left_x(p)); procrustes(left_y(p));
  7496. procrustes(x_coord(p)); procrustes(y_coord(p));
  7497. procrustes(right_x(p)); procrustes(right_y(p));@/
  7498. p:=link(p); left_type(p):=k;
  7499. if k<max_quarterword then incr(k)@+else k:=1;
  7500. until p=cur_spec;
  7501. if chopped then
  7502.   begin print_err("Curve out of range");
  7503. @.Curve out of range@>
  7504.   help4("At least one of the coordinates in the path I'm about to")@/
  7505.     ("digitize was really huge (potentially bigger than 4095).")@/
  7506.     ("So I've cut it back to the maximum size.")@/
  7507.     ("The results will probably be pretty wild.");
  7508.   put_get_error;
  7509.   end
  7510. @ We may need to get rid of constant ``dead'' cubics that clutter up
  7511. the data structure and interfere with autorounding.
  7512. @<Declare subroutines needed by |make_spec|@>=
  7513. procedure remove_cubic(@!p:pointer); {removes the cubic following~|p|}
  7514. var @!q:pointer; {the node that disappears}
  7515. begin q:=link(p); right_type(p):=right_type(q); link(p):=link(q);@/
  7516. x_coord(p):=x_coord(q); y_coord(p):=y_coord(q);@/
  7517. right_x(p):=right_x(q); right_y(p):=right_y(q);@/
  7518. free_node(q,knot_node_size);
  7519. @ The subdivision process proceeds by first swapping $x\swap-x$, if
  7520. necessary, to ensure that $x'\G0$; then swapping $y\swap-y$, if necessary,
  7521. to ensure that $y'\G0$; and finally swapping $x\swap y$, if necessary,
  7522. to ensure that $x'\G y'$.
  7523. Recall that the octant codes have been defined in such a way that, for
  7524. example, |third_octant=first_octant+negate_x+switch_x_and_y|. The program
  7525. uses the fact that |negate_x<negate_y<switch_x_and_y| to handle ``double
  7526. negation'': If |c| is an octant code that possibly involves |negate_x|
  7527. and/or |negate_y|, but not |switch_x_and_y|, then negating~|y| changes~|c|
  7528. either to |c+negate_y| or |c-negate_y|, depending on whether
  7529. |c<=negate_y| or |c>negate_y|. Octant codes are always greater than zero.
  7530. The first step is to subdivide on |x| and |y| only, so that horizontal
  7531. and vertical autorounding can be done before we compare $x'$ to $y'$.
  7532. @<Declare subroutines needed by |make_spec|@>=
  7533. @t\4@>@<Declare the procedure called |split_cubic|@>@;
  7534. procedure quadrant_subdivide;
  7535. label continue,exit;
  7536. var @!p,@!q,@!r,@!s,@!pp,@!qq:pointer; {for traversing the lists}
  7537. @!first_x,@!first_y:scaled; {unnegated coordinates of node |cur_spec|}
  7538. @!del1,@!del2,@!del3,@!del,@!dmax:scaled; {proportional to the control
  7539.   points of a quadratic derived from a cubic}
  7540. @!t:fraction; {where a quadratic crosses zero}
  7541. @!dest_x,@!dest_y:scaled; {final values of |x| and |y| in the current cubic}
  7542. @!constant_x:boolean; {is |x| constant between |p| and |q|?}
  7543. begin p:=cur_spec; first_x:=x_coord(cur_spec); first_y:=y_coord(cur_spec);
  7544. repeat continue: q:=link(p);
  7545. @<Subdivide the cubic between |p| and |q| so that the results travel
  7546.   toward the right halfplane@>;
  7547. @<Subdivide all cubics between |p| and |q| so that the results travel
  7548.   toward the first quadrant; but |return| or |goto continue| if the
  7549.   cubic from |p| to |q| was dead@>;
  7550. p:=q;
  7551. until p=cur_spec;
  7552. exit:end;
  7553. @ All three subdivision processes are similar, so it's possible to
  7554. get the general idea by studying the first one (which is the simplest).
  7555. The calculation makes use of the fact that the derivatives of
  7556. Bernshte{\u\i}n polynomials satisfy
  7557. $B'(z_0,z_1,\ldots,z_n;t)=nB(z_1-z_0,\ldots,z_n-z_{n-1};t)$.
  7558. When this routine begins, |right_type(p)| is |explicit|; we should
  7559. set |right_type(p):=first_octant|. However, no assignment is made,
  7560. because |explicit=first_octant|. The author apologizes for using
  7561. such trickery here; it is really hard to do redundant computations
  7562. just for the sake of purity.
  7563. @<Subdivide the cubic between |p| and |q| so that the results travel
  7564.   toward the right halfplane...@>=
  7565. if q=cur_spec then
  7566.   begin dest_x:=first_x; dest_y:=first_y;
  7567.   end
  7568. else  begin dest_x:=x_coord(q); dest_y:=y_coord(q);
  7569.   end;
  7570. del1:=right_x(p)-x_coord(p); del2:=left_x(q)-right_x(p);
  7571. del3:=dest_x-left_x(q);
  7572. @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
  7573.   also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
  7574. if del=0 then constant_x:=true
  7575. else  begin constant_x:=false;
  7576.   if del<0 then @<Complement the |x| coordinates of the
  7577.     cubic between |p| and~|q|@>;
  7578.   t:=crossing_point(del1,del2,del3);
  7579.   if t<fraction_one then
  7580.     @<Subdivide the cubic with respect to $x'$, possibly twice@>;
  7581.   end
  7582. @ If |del1=del2=del3=0|, it's impossible to obey the title of this
  7583. section. We just set |del=0| in that case.
  7584. @^inner loop@>
  7585. @<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>=
  7586. if del1<>0 then del:=del1
  7587. else if del2<>0 then del:=del2
  7588. else del:=del3;
  7589. if del<>0 then
  7590.   begin dmax:=abs(del1);
  7591.   if abs(del2)>dmax then dmax:=abs(del2);
  7592.   if abs(del3)>dmax then dmax:=abs(del3);
  7593.   while dmax<fraction_half do
  7594.     begin double(dmax); double(del1); double(del2); double(del3);
  7595.     end;
  7596.   end
  7597. @ During the subdivision phases of |make_spec|, the |x_coord| and |y_coord|
  7598. fields of node~|q| are not transformed to agree with the octant
  7599. stated in |right_type(p)|; they remain consistent with |right_type(q)|.
  7600. But |left_x(q)| and |left_y(q)| are governed by |right_type(p)|.
  7601. @<Complement the |x| coordinates...@>=
  7602. begin negate(x_coord(p)); negate(right_x(p));
  7603. negate(left_x(q));@/
  7604. negate(del1); negate(del2); negate(del3);@/
  7605. negate(dest_x);
  7606. right_type(p):=first_octant+negate_x;
  7607. @ When a cubic is split at a |fraction| value |t|, we obtain two cubics
  7608. whose B\'ezier control points are obtained by a generalization of the
  7609. bisection process: The formula
  7610. `$z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$' becomes
  7611. `$z_k^{(j+1)}=t[z_k^{(j)},z\k^{(j)}]$'.
  7612. It is convenient to define a \.{WEB} macro |t_of_the_way| such that
  7613. |t_of_the_way(a)(b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|.
  7614. If |0<=t<=1|, the quantity |t[a,b]| is always between |a| and~|b|, even in
  7615. the presence of rounding errors. Our subroutines
  7616. also obey the identity |t[a,b]+t[b,a]=a+b|.
  7617. @d t_of_the_way_end(#)==#,t@=)@>
  7618. @d t_of_the_way(#)==#-take_fraction@=(@>#-t_of_the_way_end
  7619. @<Declare the procedure called |split_cubic|@>=
  7620. procedure split_cubic(@!p:pointer;@!t:fraction;
  7621.   @!xq,@!yq:scaled); {splits the cubic after |p|}
  7622. var @!v:scaled; {an intermediate value}
  7623. @!q,@!r:pointer; {for list manipulation}
  7624. begin q:=link(p); r:=get_node(knot_node_size); link(p):=r; link(r):=q;@/
  7625. left_type(r):=left_type(q); right_type(r):=right_type(p);@#
  7626. v:=t_of_the_way(right_x(p))(left_x(q));
  7627. right_x(p):=t_of_the_way(x_coord(p))(right_x(p));
  7628. left_x(q):=t_of_the_way(left_x(q))(xq);
  7629. left_x(r):=t_of_the_way(right_x(p))(v);
  7630. right_x(r):=t_of_the_way(v)(left_x(q));
  7631. x_coord(r):=t_of_the_way(left_x(r))(right_x(r));@#
  7632. v:=t_of_the_way(right_y(p))(left_y(q));
  7633. right_y(p):=t_of_the_way(y_coord(p))(right_y(p));
  7634. left_y(q):=t_of_the_way(left_y(q))(yq);
  7635. left_y(r):=t_of_the_way(right_y(p))(v);
  7636. right_y(r):=t_of_the_way(v)(left_y(q));
  7637. y_coord(r):=t_of_the_way(left_y(r))(right_y(r));
  7638. @ Since $x'(t)$ is a quadratic equation, it can cross through zero
  7639. at~most twice. When it does cross zero, we make doubly sure that the
  7640. derivative is really zero at the splitting point, in case rounding errors
  7641. have caused the split cubic to have an apparently nonzero derivative.
  7642. We also make sure that the split cubic is monotonic.
  7643. @<Subdivide the cubic with respect to $x'$, possibly twice@>=
  7644. begin split_cubic(p,t,dest_x,dest_y); r:=link(p);
  7645. if right_type(r)>negate_x then right_type(r):=first_octant
  7646. else right_type(r):=first_octant+negate_x;
  7647. if x_coord(r)<x_coord(p) then x_coord(r):=x_coord(p);
  7648. left_x(r):=x_coord(r);
  7649. if right_x(p)>x_coord(r) then right_x(p):=x_coord(r);
  7650.  {we always have |x_coord(p)<=right_x(p)|}
  7651. negate(x_coord(r)); right_x(r):=x_coord(r);
  7652. negate(left_x(q)); negate(dest_x);@/
  7653. del2:=t_of_the_way(del2)(del3);
  7654.   {now |0,del2,del3| represent $x'$ on the remaining interval}
  7655. if del2>0 then del2:=0;
  7656. t:=crossing_point(0,-del2,-del3);
  7657. if t<fraction_one then @<Subdivide the cubic a second time
  7658.   with respect to $x'$@>
  7659. else begin if x_coord(r)>dest_x then
  7660.     begin x_coord(r):=dest_x; left_x(r):=-x_coord(r); right_x(r):=x_coord(r);
  7661.     end;
  7662.   if left_x(q)>dest_x then left_x(q):=dest_x
  7663.   else if left_x(q)<x_coord(r) then left_x(q):=x_coord(r);
  7664.   end;
  7665. @ @<Subdivide the cubic a second time with respect to $x'$@>=
  7666. begin split_cubic(r,t,dest_x,dest_y); s:=link(r);
  7667. if x_coord(s)<dest_x then x_coord(s):=dest_x;
  7668. if x_coord(s)<x_coord(r) then x_coord(s):=x_coord(r);
  7669. right_type(s):=right_type(p);
  7670. left_x(s):=x_coord(s); {now |x_coord(r)=right_x(r)<=left_x(s)|}
  7671. if left_x(q)<dest_x then left_x(q):=-dest_x
  7672. else if left_x(q)>x_coord(s) then left_x(q):=-x_coord(s)
  7673. else negate(left_x(q));
  7674. negate(x_coord(s)); right_x(s):=x_coord(s);
  7675. @ The process of subdivision with respect to $y'$ is like that with respect
  7676. to~$x'$, with the slight additional complication that two or three cubics
  7677. might now appear between |p| and~|q|.
  7678. @<Subdivide all cubics between |p| and |q| so that the results travel
  7679.   toward the first quadrant...@>=
  7680. pp:=p;
  7681. repeat qq:=link(pp);
  7682. abnegate(x_coord(qq),y_coord(qq),right_type(qq),right_type(pp));
  7683. dest_x:=cur_x; dest_y:=cur_y;@/
  7684. del1:=right_y(pp)-y_coord(pp); del2:=left_y(qq)-right_y(pp);
  7685. del3:=dest_y-left_y(qq);
  7686. @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
  7687.   also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
  7688. if del<>0 then {they weren't all zero}
  7689.   begin if del<0 then @<Complement the |y| coordinates of the
  7690.     cubic between |pp| and~|qq|@>;
  7691.   t:=crossing_point(del1,del2,del3);
  7692.   if t<fraction_one then
  7693.     @<Subdivide the cubic with respect to $y'$, possibly twice@>;
  7694.   end
  7695. else @<Do any special actions needed when |y| is constant;
  7696.   |return| or |goto continue| if a dead cubic from |p| to |q| is removed@>;
  7697. pp:=qq;
  7698. until pp=q;
  7699. if constant_x then @<Correct the octant code in segments with decreasing |y|@>
  7700. @ @<Complement the |y| coordinates...@>=
  7701. begin negate(y_coord(pp)); negate(right_y(pp));
  7702. negate(left_y(qq));@/
  7703. negate(del1); negate(del2); negate(del3);@/
  7704. negate(dest_y);
  7705. right_type(pp):=right_type(pp)+negate_y;
  7706. @ @<Subdivide the cubic with respect to $y'$, possibly twice@>=
  7707. begin split_cubic(pp,t,dest_x,dest_y); r:=link(pp);
  7708. if right_type(r)>negate_y then right_type(r):=right_type(r)-negate_y
  7709. else right_type(r):=right_type(r)+negate_y;
  7710. if y_coord(r)<y_coord(pp) then y_coord(r):=y_coord(pp);
  7711. left_y(r):=y_coord(r);
  7712. if right_y(pp)>y_coord(r) then right_y(pp):=y_coord(r);
  7713.  {we always have |y_coord(pp)<=right_y(pp)|}
  7714. negate(y_coord(r)); right_y(r):=y_coord(r);
  7715. negate(left_y(qq)); negate(dest_y);@/
  7716. if x_coord(r)<x_coord(pp) then x_coord(r):=x_coord(pp)
  7717. else if x_coord(r)>dest_x then x_coord(r):=dest_x;
  7718. if left_x(r)>x_coord(r) then
  7719.   begin left_x(r):=x_coord(r);
  7720.   if right_x(pp)>x_coord(r) then right_x(pp):=x_coord(r);
  7721.   end;
  7722. if right_x(r)<x_coord(r) then
  7723.   begin right_x(r):=x_coord(r);
  7724.   if left_x(qq)<x_coord(r) then left_x(qq):=x_coord(r);
  7725.   end;
  7726. del2:=t_of_the_way(del2)(del3);
  7727.   {now |0,del2,del3| represent $y'$ on the remaining interval}
  7728. if del2>0 then del2:=0;
  7729. t:=crossing_point(0,-del2,-del3);
  7730. if t<fraction_one then @<Subdivide the cubic a second time
  7731.   with respect to $y'$@>
  7732. else begin if y_coord(r)>dest_y then
  7733.     begin y_coord(r):=dest_y; left_y(r):=-y_coord(r); right_y(r):=y_coord(r);
  7734.     end;
  7735.   if left_y(qq)>dest_y then left_y(qq):=dest_y
  7736.   else if left_y(qq)<y_coord(r) then left_y(qq):=y_coord(r);
  7737.   end;
  7738. @ @<Subdivide the cubic a second time with respect to $y'$@>=
  7739. begin split_cubic(r,t,dest_x,dest_y); s:=link(r);@/
  7740. if y_coord(s)<dest_y then y_coord(s):=dest_y;
  7741. if y_coord(s)<y_coord(r) then y_coord(s):=y_coord(r);
  7742. right_type(s):=right_type(pp);
  7743. left_y(s):=y_coord(s); {now |y_coord(r)=right_y(r)<=left_y(s)|}
  7744. if left_y(qq)<dest_y then left_y(qq):=-dest_y
  7745. else if left_y(qq)>y_coord(s) then left_y(qq):=-y_coord(s)
  7746. else negate(left_y(qq));
  7747. negate(y_coord(s)); right_y(s):=y_coord(s);
  7748. if x_coord(s)<x_coord(r) then x_coord(s):=x_coord(r)
  7749. else if x_coord(s)>dest_x then x_coord(s):=dest_x;
  7750. if left_x(s)>x_coord(s) then
  7751.   begin left_x(s):=x_coord(s);
  7752.   if right_x(r)>x_coord(s) then right_x(r):=x_coord(s);
  7753.   end;
  7754. if right_x(s)<x_coord(s) then
  7755.   begin right_x(s):=x_coord(s);
  7756.   if left_x(qq)<x_coord(s) then left_x(qq):=x_coord(s);
  7757.   end;
  7758. @ If the cubic is constant in $y$ and increasing in $x$, we have classified
  7759. it as traveling in the first octant. If the cubic is constant
  7760. in~$y$ and decreasing in~$x$, it is desirable to classify it as traveling
  7761. in the fifth octant (not the fourth), because autorounding will be consistent
  7762. with respect to doublepaths only if the octant number changes by four when
  7763. the path is reversed. Therefore we negate the $y$~coordinates
  7764. when they are constant but the curve is decreasing in~$x$; this gives
  7765. the desired result except in pathological paths.
  7766. If the cubic is ``dead,'' i.e., constant in both |x| and |y|, we remove
  7767. it unless it is the only cubic in the entire path. We |goto continue|
  7768. if it wasn't the final cubic, so that the test |p=cur_spec| does not
  7769. falsely imply that all cubics have been processed.
  7770. @<Do any special actions needed when |y| is constant...@>=
  7771. if constant_x then {|p=pp|, |q=qq|, and the cubic is dead}
  7772.   begin if q<>p then
  7773.     begin remove_cubic(p); {remove the dead cycle and recycle node |q|}
  7774.     if cur_spec<>q then goto continue
  7775.     else  begin cur_spec:=p; return;
  7776.       end; {the final cubic was dead and is gone}
  7777.     end;
  7778.   end
  7779. else if not odd(right_type(pp)) then {the $x$ coordinates were negated}
  7780.   @<Complement the |y| coordinates...@>
  7781. @ A similar correction to octant codes deserves to be made when |x| is
  7782. constant and |y| is decreasing.
  7783. @<Correct the octant code in segments with decreasing |y|@>=
  7784. begin pp:=p;
  7785. repeat qq:=link(pp);
  7786. if right_type(pp)>negate_y then {the $y$ coordinates were negated}
  7787.   begin right_type(pp):=right_type(pp)+negate_x;
  7788.   negate(x_coord(pp)); negate(right_x(pp)); negate(left_x(qq));
  7789.   end;
  7790. pp:=qq;
  7791. until pp=q;
  7792. @ Finally, the process of subdividing to make $x'\G y'$ is like the other
  7793. two subdivisions, with a few new twists. We skew the coordinates at this time.
  7794. @<Declare subroutines needed by |make_spec|@>=
  7795. procedure octant_subdivide;
  7796. var @!p,@!q,@!r,@!s:pointer; {for traversing the lists}
  7797. @!del1,@!del2,@!del3,@!del,@!dmax:scaled; {proportional to the control
  7798.   points of a quadratic derived from a cubic}
  7799. @!t:fraction; {where a quadratic crosses zero}
  7800. @!dest_x,@!dest_y:scaled; {final values of |x| and |y| in the current cubic}
  7801. begin p:=cur_spec;
  7802. repeat q:=link(p);@/
  7803. x_coord(p):=x_coord(p)-y_coord(p);
  7804. right_x(p):=right_x(p)-right_y(p);
  7805. left_x(q):=left_x(q)-left_y(q);@/
  7806. @<Subdivide the cubic between |p| and |q| so that the results travel
  7807.   toward the first octant@>;
  7808. p:=q;
  7809. until p=cur_spec;
  7810. @ @<Subdivide the cubic between |p| and |q| so that the results travel
  7811.   toward the first octant@>=
  7812. @<Set up the variables |(del1,del2,del3)| to represent $x'-y'$@>;
  7813. @<Scale up |del1|, |del2|, and |del3| for greater accuracy;
  7814.   also set |del| to the first nonzero element of |(del1,del2,del3)|@>;
  7815. if del<>0 then {they weren't all zero}
  7816.   begin if del<0 then @<Swap the |x| and |y| coordinates of the
  7817.     cubic between |p| and~|q|@>;
  7818.   t:=crossing_point(del1,del2,del3);
  7819.   if t<fraction_one then
  7820.     @<Subdivide the cubic with respect to $x'-y'$, possibly twice@>;
  7821.   end
  7822. @ @<Set up the variables |(del1,del2,del3)| to represent $x'-y'$@>=
  7823. if q=cur_spec then
  7824.   begin unskew(x_coord(q),y_coord(q),right_type(q));
  7825.   skew(cur_x,cur_y,right_type(p)); dest_x:=cur_x; dest_y:=cur_y;
  7826.   end
  7827. else  begin abnegate(x_coord(q),y_coord(q),right_type(q),right_type(p));
  7828.   dest_x:=cur_x-cur_y; dest_y:=cur_y;
  7829.   end;
  7830. del1:=right_x(p)-x_coord(p); del2:=left_x(q)-right_x(p);
  7831. del3:=dest_x-left_x(q)
  7832. @ The swapping here doesn't simply interchange |x| and |y| values,
  7833. because the coordinates are skewed. It turns out that this is easier
  7834. than ordinary swapping, because it can be done in two assignment statements
  7835. rather than three.
  7836. @ @<Swap the |x| and |y| coordinates...@>=
  7837. begin y_coord(p):=x_coord(p)+y_coord(p); negate(x_coord(p));@/
  7838. right_y(p):=right_x(p)+right_y(p); negate(right_x(p));@/
  7839. left_y(q):=left_x(q)+left_y(q); negate(left_x(q));@/
  7840. negate(del1); negate(del2); negate(del3);@/
  7841. dest_y:=dest_x+dest_y; negate(dest_x);@/
  7842. right_type(p):=right_type(p)+switch_x_and_y;
  7843. @ A somewhat tedious case analysis is carried out here to make sure that
  7844. nasty rounding errors don't destroy our assumptions of monotonicity.
  7845. @<Subdivide the cubic with respect to $x'-y'$, possibly twice@>=
  7846. begin split_cubic(p,t,dest_x,dest_y); r:=link(p);
  7847. if right_type(r)>switch_x_and_y then right_type(r):=right_type(r)-switch_x_and_y
  7848. else right_type(r):=right_type(r)+switch_x_and_y;
  7849. if y_coord(r)<y_coord(p) then y_coord(r):=y_coord(p)
  7850. else if y_coord(r)>dest_y then y_coord(r):=dest_y;
  7851. if x_coord(p)+y_coord(r)>dest_x+dest_y then
  7852.   y_coord(r):=dest_x+dest_y-x_coord(p);
  7853. if left_y(r)>y_coord(r) then
  7854.   begin left_y(r):=y_coord(r);
  7855.   if right_y(p)>y_coord(r) then right_y(p):=y_coord(r);
  7856.   end;
  7857. if right_y(r)<y_coord(r) then
  7858.   begin right_y(r):=y_coord(r);
  7859.   if left_y(q)<y_coord(r) then left_y(q):=y_coord(r);
  7860.   end;
  7861. if x_coord(r)<x_coord(p) then x_coord(r):=x_coord(p)
  7862. else if x_coord(r)+y_coord(r)>dest_x+dest_y then
  7863.   x_coord(r):=dest_x+dest_y-y_coord(r);
  7864. left_x(r):=x_coord(r);
  7865. if right_x(p)>x_coord(r) then right_x(p):=x_coord(r);
  7866.  {we always have |x_coord(p)<=right_x(p)|}
  7867. y_coord(r):=y_coord(r)+x_coord(r); right_y(r):=right_y(r)+x_coord(r);@/
  7868. negate(x_coord(r)); right_x(r):=x_coord(r);@/
  7869. left_y(q):=left_y(q)+left_x(q); negate(left_x(q));@/
  7870. dest_y:=dest_y+dest_x; negate(dest_x);
  7871. if right_y(r)<y_coord(r) then
  7872.   begin right_y(r):=y_coord(r);
  7873.   if left_y(q)<y_coord(r) then left_y(q):=y_coord(r);
  7874.   end;
  7875. del2:=t_of_the_way(del2)(del3);
  7876.   {now |0,del2,del3| represent $x'-y'$ on the remaining interval}
  7877. if del2>0 then del2:=0;
  7878. t:=crossing_point(0,-del2,-del3);
  7879. if t<fraction_one then
  7880.   @<Subdivide the cubic a second time with respect to $x'-y'$@>
  7881. else begin if x_coord(r)>dest_x then
  7882.     begin x_coord(r):=dest_x; left_x(r):=-x_coord(r); right_x(r):=x_coord(r);
  7883.     end;
  7884.   if left_x(q)>dest_x then left_x(q):=dest_x
  7885.   else if left_x(q)<x_coord(r) then left_x(q):=x_coord(r);
  7886.   end;
  7887. @ @<Subdivide the cubic a second time with respect to $x'-y'$@>=
  7888. begin split_cubic(r,t,dest_x,dest_y); s:=link(r);@/
  7889. if y_coord(s)<y_coord(r) then y_coord(s):=y_coord(r)
  7890. else if y_coord(s)>dest_y then y_coord(s):=dest_y;
  7891. if x_coord(r)+y_coord(s)>dest_x+dest_y then
  7892.   y_coord(s):=dest_x+dest_y-x_coord(r);
  7893. if left_y(s)>y_coord(s) then
  7894.   begin left_y(s):=y_coord(s);
  7895.   if right_y(r)>y_coord(s) then right_y(r):=y_coord(s);
  7896.   end;
  7897. if right_y(s)<y_coord(s) then
  7898.   begin right_y(s):=y_coord(s);
  7899.   if left_y(q)<y_coord(s) then left_y(q):=y_coord(s);
  7900.   end;
  7901. if x_coord(s)+y_coord(s)>dest_x+dest_y then x_coord(s):=dest_x+dest_y-y_coord(s)
  7902. else begin if x_coord(s)<dest_x then x_coord(s):=dest_x;
  7903.   if x_coord(s)<x_coord(r) then x_coord(s):=x_coord(r);
  7904.   end;
  7905. right_type(s):=right_type(p);
  7906. left_x(s):=x_coord(s); {now |x_coord(r)=right_x(r)<=left_x(s)|}
  7907. if left_x(q)<dest_x then
  7908.   begin left_y(q):=left_y(q)+dest_x; left_x(q):=-dest_x;@+end
  7909. else if left_x(q)>x_coord(s) then
  7910.   begin left_y(q):=left_y(q)+x_coord(s); left_x(q):=-x_coord(s);@+end
  7911. else begin left_y(q):=left_y(q)+left_x(q); negate(left_x(q));@+end;
  7912. y_coord(s):=y_coord(s)+x_coord(s); right_y(s):=right_y(s)+x_coord(s);@/
  7913. negate(x_coord(s)); right_x(s):=x_coord(s);@/
  7914. if right_y(s)<y_coord(s) then
  7915.   begin right_y(s):=y_coord(s);
  7916.   if left_y(q)<y_coord(s) then left_y(q):=y_coord(s);
  7917.   end;
  7918. @ It's time now to consider ``autorounding,'' which tries to make horizontal,
  7919. vertical, and diagonal tangents occur at places that will produce appropriate
  7920. images after the curve is digitized.
  7921. The first job is to fix things so that |x(t)| is an integer multiple of the
  7922. current ``granularity'' when the derivative $x'(t)$ crosses through zero.
  7923. The given cyclic path contains regions where $x'(t)\G0$ and regions
  7924. where $x'(t)\L0$. The |quadrant_subdivide| routine is called into action
  7925. before any of the path coordinates have been skewed, but some of them
  7926. may have been negated. In regions where $x'(t)\G0$ we have |right_type=
  7927. first_octant| or |right_type=fourth_octant|; in regions where $x'(t)\L0$,
  7928. we have |right_type=fifth_octant| or |right_type=eighth_octant|.
  7929. Within any such region the transformed $x$ values increase monotonically
  7930. from, say, $x_0$ to~$x_1$. We want to modify things by applying a linear
  7931. transformation to all $x$ coordinates in the region, after which
  7932. the $x$ values will increase monotonically from round$(x_0)$ to round$(x_1)$.
  7933. This rounding scheme sounds quite simple, and it usually is. But several
  7934. complications can arise that might make the task more difficult. In the
  7935. first place, autorounding is inappropriate at cusps where $x'$ jumps
  7936. discontinuously past zero without ever being zero. In the second place,
  7937. the current pen might be unsymmetric in such a way that $x$ coordinates
  7938. should round differently when $x'$ becomes positive than when it becomes
  7939. negative. These considerations imply that round$(x_0)$ might be greater
  7940. than round$(x_1)$, even though $x_0\L x_1$; in such cases we do not want
  7941. to carry out the linear transformation. Furthermore, it's possible to have
  7942. round$(x_1)-\hbox{round} (x_0)$ positive but much greater than $x_1-x_0$;
  7943. then the transformation might distort the curve drastically, and again we
  7944. want to avoid it. Finally, the rounded points must be consistent between
  7945. adjacent regions, hence we can't transform one region without knowing
  7946. about its neighbors.
  7947. To handle all these complications, we must first look at the whole
  7948. cycle and choose rounded $x$ values that are ``safe.'' The following
  7949. procedure does this: Given $m$~values $(b_0,b_1,\ldots,b_{m-1})$ before
  7950. rounding and $m$~corresponding values $(a_0,a_1,\ldots,a_{m-1})$ that would
  7951. be desirable after rounding, the |make_safe| routine sets $a$'s to $b$'s
  7952. if necessary so that $0\L(a\k-a_k)/(b\k-b_k)\L2$ afterwards. It is
  7953. symmetric under cyclic permutation, reversal, and/or negation of the inputs.
  7954. (Instead of |a|, |b|, and~|m|, the program uses the names |after|,
  7955. |before|, and |cur_rounding_ptr|.)
  7956. @<Declare subroutines needed by |make_spec|@>=
  7957. procedure make_safe;
  7958. var @!k:0..max_wiggle; {runs through the list of inputs}
  7959. @!all_safe:boolean; {does everything look OK so far?}
  7960. @!next_a:scaled; {|after[k]| before it might have changed}
  7961. @!delta_a,@!delta_b:scaled; {|after[k+1]-after[k]| and |before[k+1]-before[k]|}
  7962. begin before[cur_rounding_ptr]:=before[0]; {wrap around}
  7963. node_to_round[cur_rounding_ptr]:=node_to_round[0];
  7964. repeat after[cur_rounding_ptr]:=after[0]; all_safe:=true; next_a:=after[0];
  7965. for k:=0 to cur_rounding_ptr-1 do
  7966.   begin delta_b:=before[k+1]-before[k];
  7967.   if delta_b>=0 then delta_a:=after[k+1]-next_a
  7968.   else delta_a:=next_a-after[k+1];
  7969.   next_a:=after[k+1];
  7970.   if (delta_a<0)or(delta_a>abs(delta_b+delta_b)) then
  7971.     begin all_safe:=false; after[k]:=before[k];
  7972.     if k=cur_rounding_ptr-1 then after[0]:=before[0]
  7973.     else after[k+1]:=before[k+1];
  7974.     end;
  7975.   end;
  7976. until all_safe;
  7977. @ The global arrays used by |make_safe| are accompanied by an array of
  7978. pointers into the current knot list.
  7979. @<Glob...@>=
  7980. @!before,@!after:array[0..max_wiggle] of scaled; {data for |make_safe|}
  7981. @!node_to_round:array[0..max_wiggle] of pointer; {reference back to the path}
  7982. @!cur_rounding_ptr:0..max_wiggle; {how many are being used}
  7983. @!max_rounding_ptr:0..max_wiggle; {how many have been used}
  7984. @ @<Set init...@>=
  7985. max_rounding_ptr:=0;
  7986. @ New entries go into the tables via the |before_and_after| routine:
  7987. @<Declare subroutines needed by |make_spec|@>=
  7988. procedure before_and_after(@!b,@!a:scaled;@!p:pointer);
  7989. begin if cur_rounding_ptr=max_rounding_ptr then
  7990.   if max_rounding_ptr<max_wiggle then incr(max_rounding_ptr)
  7991.   else overflow("rounding table size",max_wiggle);
  7992. @:METAFONT capacity exceeded rounding table size}{\quad rounding table size@>
  7993. after[cur_rounding_ptr]:=a; before[cur_rounding_ptr]:=b;
  7994. node_to_round[cur_rounding_ptr]:=p; incr(cur_rounding_ptr);
  7995. @ A global variable called |cur_gran| is used instead of |internal[
  7996. granularity]|, because we want to work with a number that's guaranteed to
  7997. be positive.
  7998. @<Glob...@>=
  7999. @!cur_gran:scaled; {the current granularity (which normally is |unity|)}
  8000. @ The |good_val| function computes a number |a| that's as close as
  8001. possible to~|b|, with the property that |a+o| is a multiple of
  8002. |cur_gran|.
  8003. If we assume that |cur_gran| is even (since it will in fact be a multiple
  8004. of |unity| in all reasonable applications), we have the identity
  8005. |good_val(-b-1,-o)=-good_val(b,o)|.
  8006. @<Declare subroutines needed by |make_spec|@>=
  8007. function good_val(@!b,@!o:scaled):scaled;
  8008. var @!a:scaled; {accumulator}
  8009. begin a:=b+o;
  8010. if a>=0 then a:=a-(a mod cur_gran)-o
  8011. else a:=a+((-(a+1)) mod cur_gran)-cur_gran+1-o;
  8012. if b-a<a+cur_gran-b then good_val:=a
  8013. else good_val:=a+cur_gran;
  8014. @ When we're rounding a doublepath, we might need to compromise between
  8015. two opposing tendencies, if the pen thickness is not a multiple of the
  8016. granularity. The following ``compromise'' adjustment, suggested by
  8017. John Hobby, finds the best way out of the dilemma. (Only the value
  8018. @^Hobby, John Douglas@>
  8019. modulo |cur_gran| is relevant in our applications, so the result turns
  8020. out to be essentially symmetric in |u| and~|v|.)
  8021. @<Declare subroutines needed by |make_spec|@>=
  8022. function compromise(@!u,@!v:scaled):scaled;
  8023. begin compromise:=half(good_val(u+u,-u-v));
  8024. @ Here, then, is the procedure that rounds $x$ coordinates as described;
  8025. it does the same for $y$ coordinates too, independently.
  8026. @<Declare subroutines needed by |make_spec|@>=
  8027. procedure xy_round;
  8028. var @!p,@!q:pointer; {list manipulation registers}
  8029. @!b,@!a:scaled; {before and after values}
  8030. @!pen_edge:scaled; {offset that governs rounding}
  8031. @!alpha:fraction; {coefficient of linear transformation}
  8032. begin cur_gran:=abs(internal[granularity]);
  8033. if cur_gran=0 then cur_gran:=unity;
  8034. p:=cur_spec; cur_rounding_ptr:=0;
  8035. repeat q:=link(p);
  8036. @<If node |q| is a transition point for |x| coordinates,
  8037.   compute and save its before-and-after coordinates@>;
  8038. p:=q;
  8039. until p=cur_spec;
  8040. if cur_rounding_ptr>0 then @<Transform the |x| coordinates@>;
  8041. p:=cur_spec; cur_rounding_ptr:=0;
  8042. repeat q:=link(p);
  8043. @<If node |q| is a transition point for |y| coordinates,
  8044.   compute and save its before-and-after coordinates@>;
  8045. p:=q;
  8046. until p=cur_spec;
  8047. if cur_rounding_ptr>0 then @<Transform the |y| coordinates@>;
  8048. @ When |x| has been negated, the |octant| codes are even. We allow
  8049. for an error of up to .01 pixel (i.e., 655 |scaled| units) in the
  8050. derivative calculations at transition nodes.
  8051. @<If node |q| is a transition point for |x| coordinates...@>=
  8052. if odd(right_type(p))<>odd(right_type(q)) then
  8053.   begin if odd(right_type(q)) then b:=x_coord(q)@+else b:=-x_coord(q);
  8054.   if (abs(x_coord(q)-right_x(q))<655)or@|
  8055.     (abs(x_coord(q)+left_x(q))<655) then
  8056.     @<Compute before-and-after |x| values based on the current pen@>
  8057.   else a:=b;
  8058.   if abs(a)>max_allowed then
  8059.     if a>0 then a:=max_allowed@+else a:=-max_allowed;
  8060.   before_and_after(b,a,q);
  8061.   end
  8062. @ When we study the data representation for pens, we'll learn that the
  8063. |x|~coordinate of the current pen's west edge is
  8064. $$\hbox{|y_coord(link(cur_pen+seventh_octant))|},$$
  8065. and that there are similar ways to address other important offsets.
  8066. An ``|east_west_edge|'' is computed as a compromise between east and
  8067. west, for use in doublepaths, in case the two edges have conflicting
  8068. tendencies.
  8069. @d north_edge(#)==y_coord(link(#+fourth_octant))
  8070. @d south_edge(#)==y_coord(link(#+first_octant))
  8071. @d east_edge(#)==y_coord(link(#+second_octant))
  8072. @d west_edge(#)==y_coord(link(#+seventh_octant))
  8073. @d north_south_edge(#)==mem[#+10].int {compromise between north and south}
  8074. @d east_west_edge(#)==mem[#+11].int {compromise between east and west}
  8075. @d NE_SW_edge(#)==mem[#+12].int {compromise between northeast and southwest}
  8076. @d NW_SE_edge(#)==mem[#+13].int {compromise between northwest and southeast}
  8077. @<Compute before-and-after |x| values based on the current pen@>=
  8078. begin if cur_pen=null_pen then pen_edge:=0
  8079. else if cur_path_type=double_path_code then
  8080.   pen_edge:=compromise(east_edge(cur_pen),west_edge(cur_pen))
  8081. else if odd(right_type(q)) then pen_edge:=west_edge(cur_pen)
  8082. else pen_edge:=east_edge(cur_pen);
  8083. a:=good_val(b,pen_edge);
  8084. @  The monotone transformation computed here with fixed-point arithmetic is
  8085. guaranteed to take consecutive |before| values $(b,b')$ into consecutive
  8086. |after| values $(a,a')$, even in the presence of rounding errors,
  8087. as long as $\vert b-b'\vert<2^{28}$.
  8088. @<Transform the |x| coordinates@>=
  8089. begin make_safe;
  8090. repeat decr(cur_rounding_ptr);
  8091. if (after[cur_rounding_ptr]<>before[cur_rounding_ptr])or@|
  8092.  (after[cur_rounding_ptr+1]<>before[cur_rounding_ptr+1]) then
  8093.   begin p:=node_to_round[cur_rounding_ptr];
  8094.   if odd(right_type(p)) then
  8095.     begin b:=before[cur_rounding_ptr]; a:=after[cur_rounding_ptr];
  8096.     end
  8097.   else  begin b:=-before[cur_rounding_ptr]; a:=-after[cur_rounding_ptr];
  8098.     end;
  8099.   if before[cur_rounding_ptr]=before[cur_rounding_ptr+1] then
  8100.     alpha:=fraction_one
  8101.   else alpha:=make_fraction(after[cur_rounding_ptr+1]-after[cur_rounding_ptr],@|
  8102.     before[cur_rounding_ptr+1]-before[cur_rounding_ptr]);
  8103.   repeat x_coord(p):=take_fraction(alpha,x_coord(p)-b)+a;
  8104.   right_x(p):=take_fraction(alpha,right_x(p)-b)+a;
  8105.   p:=link(p); left_x(p):=take_fraction(alpha,left_x(p)-b)+a;
  8106.   until p=node_to_round[cur_rounding_ptr+1];
  8107.   end;
  8108. until cur_rounding_ptr=0;
  8109. @ When |y| has been negated, the |octant| codes are |>negate_y|. Otherwise
  8110. these routines are essentially identical to the routines for |x| coordinates
  8111. that we have just seen.
  8112. @<If node |q| is a transition point for |y| coordinates...@>=
  8113. if (right_type(p)>negate_y)<>(right_type(q)>negate_y) then
  8114.   begin if right_type(q)<=negate_y then b:=y_coord(q)@+else b:=-y_coord(q);
  8115.   if (abs(y_coord(q)-right_y(q))<655)or@|
  8116.     (abs(y_coord(q)+left_y(q))<655) then
  8117.     @<Compute before-and-after |y| values based on the current pen@>
  8118.   else a:=b;
  8119.   if abs(a)>max_allowed then
  8120.     if a>0 then a:=max_allowed@+else a:=-max_allowed;
  8121.   before_and_after(b,a,q);
  8122.   end
  8123. @ @<Compute before-and-after |y| values based on the current pen@>=
  8124. begin if cur_pen=null_pen then pen_edge:=0
  8125. else if cur_path_type=double_path_code then
  8126.   pen_edge:=compromise(north_edge(cur_pen),south_edge(cur_pen))
  8127. else if right_type(q)<=negate_y then pen_edge:=south_edge(cur_pen)
  8128. else pen_edge:=north_edge(cur_pen);
  8129. a:=good_val(b,pen_edge);
  8130. @ @<Transform the |y| coordinates@>=
  8131. begin make_safe;
  8132. repeat decr(cur_rounding_ptr);
  8133. if (after[cur_rounding_ptr]<>before[cur_rounding_ptr])or@|
  8134.  (after[cur_rounding_ptr+1]<>before[cur_rounding_ptr+1]) then
  8135.   begin p:=node_to_round[cur_rounding_ptr];
  8136.   if right_type(p)<=negate_y then
  8137.     begin b:=before[cur_rounding_ptr]; a:=after[cur_rounding_ptr];
  8138.     end
  8139.   else  begin b:=-before[cur_rounding_ptr]; a:=-after[cur_rounding_ptr];
  8140.     end;
  8141.   if before[cur_rounding_ptr]=before[cur_rounding_ptr+1] then
  8142.     alpha:=fraction_one
  8143.   else alpha:=make_fraction(after[cur_rounding_ptr+1]-after[cur_rounding_ptr],@|
  8144.     before[cur_rounding_ptr+1]-before[cur_rounding_ptr]);
  8145.   repeat y_coord(p):=take_fraction(alpha,y_coord(p)-b)+a;
  8146.   right_y(p):=take_fraction(alpha,right_y(p)-b)+a;
  8147.   p:=link(p); left_y(p):=take_fraction(alpha,left_y(p)-b)+a;
  8148.   until p=node_to_round[cur_rounding_ptr+1];
  8149.   end;
  8150. until cur_rounding_ptr=0;
  8151. @ Rounding at diagonal tangents takes place after the subdivision into
  8152. octants is complete, hence after the coordinates have been skewed.
  8153. The details are somewhat tricky, because we want to round to points
  8154. whose skewed coordinates are halfway between integer multiples of
  8155. the granularity. Furthermore, both coordinates change when they are
  8156. rounded; this means we need a generalization of the |make_safe| routine,
  8157. ensuring safety in both |x| and |y|.
  8158. In spite of these extra complications, we can take comfort in the fact
  8159. that the basic structure of the routine is the same as before.
  8160. @<Declare subroutines needed by |make_spec|@>=
  8161. procedure diag_round;
  8162. var @!p,@!q,@!pp:pointer; {list manipulation registers}
  8163. @!b,@!a,@!bb,@!aa,@!d,@!c,@!dd,@!cc:scaled; {before and after values}
  8164. @!pen_edge:scaled; {offset that governs rounding}
  8165. @!alpha,@!beta:fraction; {coefficients of linear transformation}
  8166. @!next_a:scaled; {|after[k]| before it might have changed}
  8167. @!all_safe:boolean; {does everything look OK so far?}
  8168. @!k:0..max_wiggle; {runs through before-and-after values}
  8169. @!first_x,@!first_y:scaled; {coordinates before rounding}
  8170. begin p:=cur_spec; cur_rounding_ptr:=0;
  8171. repeat q:=link(p);
  8172. @<If node |q| is a transition point between octants,
  8173.   compute and save its before-and-after coordinates@>;
  8174. p:=q;
  8175. until p=cur_spec;
  8176. if cur_rounding_ptr>0 then @<Transform the skewed coordinates@>;
  8177. @ We negate the skewed |x| coordinates in the before-and-after table when
  8178. the octant code is greater than |switch_x_and_y|.
  8179. @<If node |q| is a transition point between octants...@>=
  8180. if right_type(p)<>right_type(q) then
  8181.   begin if right_type(q)>switch_x_and_y then b:=-x_coord(q)
  8182.   else b:=x_coord(q);
  8183.   if abs(right_type(q)-right_type(p))=switch_x_and_y then
  8184.     if (abs(x_coord(q)-right_x(q))<655)or(abs(x_coord(q)+left_x(q))<655) then
  8185.       @<Compute a good coordinate at a diagonal transition@>
  8186.     else a:=b
  8187.   else a:=b;
  8188.   before_and_after(b,a,q);
  8189.   end
  8190. @ In octants whose code number is even, $x$~has been
  8191. negated; we want to round ambiguous cases downward instead of upward,
  8192. so that the rounding will be consistent with octants whose code
  8193. number is odd. This downward bias can be achieved by
  8194. subtracting~1 from the first argument of |good_val|.
  8195. @d diag_offset(#)==x_coord(knil(link(cur_pen+#)))
  8196. @<Compute a good coordinate at a diagonal transition@>=
  8197. begin if cur_pen=null_pen then pen_edge:=0
  8198. else if cur_path_type=double_path_code then @<Compute a compromise |pen_edge|@>
  8199. else if right_type(q)<=switch_x_and_y then pen_edge:=diag_offset(right_type(q))
  8200. else pen_edge:=-diag_offset(right_type(q));
  8201. if odd(right_type(q)) then a:=good_val(b,pen_edge+half(cur_gran))
  8202. else a:=good_val(b-1,pen_edge+half(cur_gran));
  8203. @ (It seems a shame to compute these compromise offsets repeatedly. The
  8204. author would have stored them directly in the pen data structure, if the
  8205. granularity had been constant.)
  8206. @<Compute a compromise...@>=
  8207. case right_type(q) of
  8208. first_octant,second_octant:pen_edge:=compromise(diag_offset(first_octant),@|
  8209.     -diag_offset(fifth_octant));
  8210. fifth_octant,sixth_octant:pen_edge:=-compromise(diag_offset(first_octant),@|
  8211.     -diag_offset(fifth_octant));
  8212. third_octant,fourth_octant:pen_edge:=compromise(diag_offset(fourth_octant),@|
  8213.     -diag_offset(eighth_octant));
  8214. seventh_octant,eighth_octant:pen_edge:=-compromise(diag_offset(fourth_octant),@|
  8215.     -diag_offset(eighth_octant));
  8216. end {there are no other cases}
  8217. @ @<Transform the skewed coordinates@>=
  8218. begin p:=node_to_round[0]; first_x:=x_coord(p); first_y:=y_coord(p);
  8219. @<Make sure that all the diagonal roundings are safe@>;
  8220. for k:=0 to cur_rounding_ptr-1 do
  8221.   begin a:=after[k]; b:=before[k];
  8222.   aa:=after[k+1]; bb:=before[k+1];
  8223.   if (a<>b)or(aa<>bb) then
  8224.     begin p:=node_to_round[k]; pp:=node_to_round[k+1];
  8225.     @<Determine the before-and-after values of both coordinates@>;
  8226.     if b=bb then alpha:=fraction_one
  8227.     else alpha:=make_fraction(aa-a,bb-b);
  8228.     if d=dd then beta:=fraction_one
  8229.     else beta:=make_fraction(cc-c,dd-d);
  8230.     repeat x_coord(p):=take_fraction(alpha,x_coord(p)-b)+a;
  8231.     y_coord(p):=take_fraction(beta,y_coord(p)-d)+c;
  8232.     right_x(p):=take_fraction(alpha,right_x(p)-b)+a;
  8233.     right_y(p):=take_fraction(beta,right_y(p)-d)+c;
  8234.     p:=link(p); left_x(p):=take_fraction(alpha,left_x(p)-b)+a;
  8235.     left_y(p):=take_fraction(beta,left_y(p)-d)+c;
  8236.     until p=pp;
  8237.     end;
  8238.   end;
  8239. @ In node |p|, the coordinates |(b,d)| will be rounded to |(a,c)|;
  8240. in node |pp|, the coordinates |(bb,dd)| will be rounded to |(aa,cc)|.
  8241. (We transform the values from node |pp| so that they agree with the
  8242. conventions of node |p|.)
  8243. If |aa<>bb|, we know that |abs(right_type(p)-right_type(pp))=switch_x_and_y|.
  8244. @<Determine the before-and-after values of both coordinates@>=
  8245. if aa=bb then
  8246.   begin if pp=node_to_round[0] then
  8247.     unskew(first_x,first_y,right_type(pp))
  8248.   else unskew(x_coord(pp),y_coord(pp),right_type(pp));
  8249.   skew(cur_x,cur_y,right_type(p));
  8250.   bb:=cur_x; aa:=bb; dd:=cur_y; cc:=dd;
  8251.   if right_type(p)>switch_x_and_y then
  8252.     begin b:=-b; a:=-a;
  8253.     end;
  8254.   end
  8255. else  begin if right_type(p)>switch_x_and_y then
  8256.     begin bb:=-bb; aa:=-aa; b:=-b; a:=-a;
  8257.     end;
  8258.   if pp=node_to_round[0] then dd:=first_y-bb@+else dd:=y_coord(pp)-bb;
  8259.   if odd(aa-bb) then
  8260.     if right_type(p)>switch_x_and_y then cc:=dd-half(aa-bb+1)
  8261.     else cc:=dd-half(aa-bb-1)
  8262.   else cc:=dd-half(aa-bb);
  8263.   end;
  8264. d:=y_coord(p);
  8265. if odd(a-b) then
  8266.   if right_type(p)>switch_x_and_y then c:=d-half(a-b-1)
  8267.   else c:=d-half(a-b+1)
  8268. else c:=d-half(a-b)
  8269. @ @<Make sure that all the diagonal roundings are safe@>=
  8270. before[cur_rounding_ptr]:=before[0]; {cf.~|make_safe|}
  8271. node_to_round[cur_rounding_ptr]:=node_to_round[0];
  8272. repeat after[cur_rounding_ptr]:=after[0]; all_safe:=true; next_a:=after[0];
  8273. for k:=0 to cur_rounding_ptr-1 do
  8274.   begin a:=next_a; b:=before[k]; next_a:=after[k+1];
  8275.   aa:=next_a; bb:=before[k+1];
  8276.   if (a<>b)or(aa<>bb) then
  8277.     begin p:=node_to_round[k]; pp:=node_to_round[k+1];
  8278.     @<Determine the before-and-after values of both coordinates@>;
  8279.     if (aa<a)or(cc<c)or(aa-a>2*(bb-b))or(cc-c>2*(dd-d)) then
  8280.       begin all_safe:=false; after[k]:=before[k];
  8281.       if k=cur_rounding_ptr-1 then after[0]:=before[0]
  8282.       else after[k+1]:=before[k+1];
  8283.       end;
  8284.     end;
  8285.   end;
  8286. until all_safe
  8287. @ Here we get rid of ``dead'' cubics, i.e., polynomials that don't move at
  8288. all when |t|~changes, since the subdivision process might have introduced
  8289. such things.  If the cycle reduces to a single point, however, we are left
  8290. with a single dead cubic that will not be removed until later.
  8291. @<Remove dead cubics@>=
  8292. p:=cur_spec;
  8293. repeat continue: q:=link(p);
  8294. if p<>q then
  8295.   begin if x_coord(p)=right_x(p) then
  8296.    if y_coord(p)=right_y(p) then
  8297.     if x_coord(p)=left_x(q) then
  8298.      if y_coord(p)=left_y(q) then
  8299.     begin unskew(x_coord(q),y_coord(q),right_type(q));
  8300.     skew(cur_x,cur_y,right_type(p));
  8301.     if x_coord(p)=cur_x then if y_coord(p)=cur_y then
  8302.       begin remove_cubic(p); {remove the cubic following |p|}
  8303.       if q<>cur_spec then goto continue;
  8304.       cur_spec:=p; q:=p;
  8305.       end;
  8306.     end;
  8307.   end;
  8308. p:=q;
  8309. until p=cur_spec;
  8310. @ Finally we come to the last steps of |make_spec|, when boundary nodes
  8311. are inserted between cubics that move in different octants. The main
  8312. complication remaining arises from consecutive cubics whose octants
  8313. are not adjacent; we should insert more than one octant boundary
  8314. at such sharp turns, so that the envelope-forming routine will work.
  8315. For this purpose, conversion tables between numeric and Gray codes for
  8316. octants are desirable.
  8317. @<Glob...@>=
  8318. @!octant_number:array[first_octant..sixth_octant] of 1..8;
  8319. @!octant_code:array[1..8] of first_octant..sixth_octant;
  8320. @ @<Set init...@>=
  8321. octant_code[1]:=first_octant;
  8322. octant_code[2]:=second_octant;
  8323. octant_code[3]:=third_octant;
  8324. octant_code[4]:=fourth_octant;
  8325. octant_code[5]:=fifth_octant;
  8326. octant_code[6]:=sixth_octant;
  8327. octant_code[7]:=seventh_octant;
  8328. octant_code[8]:=eighth_octant;
  8329. for k:=1 to 8 do octant_number[octant_code[k]]:=k;
  8330. @ The main loop for boundary insertion deals with three consecutive
  8331. nodes |p,q,r|.
  8332. @<Insert octant boundaries and compute the turning number@>=
  8333. turning_number:=0;
  8334. p:=cur_spec; q:=link(p);
  8335. repeat r:=link(q);
  8336. if (right_type(p)<>right_type(q))or(q=r) then
  8337.   @<Insert one or more octant boundary nodes just before~|q|@>;
  8338. p:=q; q:=r;
  8339. until p=cur_spec;
  8340. @ The |new_boundary| subroutine comes in handy at this point. It inserts
  8341. a new boundary node just after a given node |p|, using a given octant code
  8342. to transform the new node's coordinates. The ``transition'' fields are
  8343. not computed here.
  8344. @<Declare subroutines needed by |make_spec|@>=
  8345. procedure new_boundary(@!p:pointer;@!octant:small_number);
  8346. var @!q,@!r:pointer; {for list manipulation}
  8347. begin q:=link(p); {we assume that |right_type(q)<>endpoint|}
  8348. r:=get_node(knot_node_size); link(r):=q; link(p):=r;
  8349. left_type(r):=left_type(q); {but possibly |left_type(q)=endpoint|}
  8350. left_x(r):=left_x(q); left_y(r):=left_y(q);
  8351. right_type(r):=endpoint; left_type(q):=endpoint;
  8352. right_octant(r):=octant; left_octant(q):=right_type(q);
  8353. unskew(x_coord(q),y_coord(q),right_type(q));
  8354. skew(cur_x,cur_y,octant); x_coord(r):=cur_x; y_coord(r):=cur_y;
  8355. @ The case |q=r| occurs if and only if |p=q=r=cur_spec|, when we want to turn
  8356. $360^\circ$ in eight steps and then remove a solitary dead cubic.
  8357. The program below happens to work in that case, but the reader isn't
  8358. expected to understand why.
  8359. @<Insert one or more octant boundary nodes just before~|q|@>=
  8360. begin new_boundary(p,right_type(p)); s:=link(p);
  8361. o1:=octant_number[right_type(p)]; o2:=octant_number[right_type(q)];
  8362. case o2-o1 of
  8363. 1,-7,7,-1: goto done;
  8364. 2,-6: clockwise:=false;
  8365. 3,-5,4,-4,5,-3: @<Decide whether or not to go clockwise@>;
  8366. 6,-2: clockwise:=true;
  8367. 0:clockwise:=rev_turns;
  8368. end; {there are no other cases}
  8369. @<Insert additional boundary nodes, then |goto done|@>;
  8370. done: if q=r then
  8371.   begin q:=link(q); r:=q; p:=s; link(s):=q; left_octant(q):=right_octant(q);
  8372.   left_type(q):=endpoint; free_node(cur_spec,knot_node_size); cur_spec:=q;
  8373.   end;
  8374. @<Fix up the transition fields and adjust the turning number@>;
  8375. @ @<Other local variables for |make_spec|@>=
  8376. @!o1,@!o2:small_number; {octant numbers}
  8377. @!clockwise:boolean; {should we turn clockwise?}
  8378. @!dx1,@!dy1,@!dx2,@!dy2:integer; {directions of travel at a cusp}
  8379. @!dmax,@!del:integer; {temporary registers}
  8380. @ A tricky question arises when a path jumps four octants. We want the
  8381. direction of turning to be counterclockwise if the curve has changed
  8382. direction by $180^\circ$, or by something so close to $180^\circ$ that
  8383. the difference is probably due to rounding errors; otherwise we want to
  8384. turn through an angle of less than $180^\circ$. This decision needs to
  8385. be made even when a curve seems to have jumped only three octants, since
  8386. a curve may approach direction $(-1,0)$ from the fourth octant, then
  8387. it might leave from direction $(+1,0)$ into the first.
  8388. The following code solves the problem by analyzing the incoming
  8389. direction |(dx1,dy1)| and the outgoing direction |(dx2,dy2)|.
  8390. @<Decide whether or not to go clockwise@>=
  8391. begin @<Compute the incoming and outgoing directions@>;
  8392. unskew(dx1,dy1,right_type(p)); del:=pyth_add(cur_x,cur_y);@/
  8393. dx1:=make_fraction(cur_x,del); dy1:=make_fraction(cur_y,del);
  8394.   {$\cos\theta_1$ and $\sin\theta_1$}
  8395. unskew(dx2,dy2,right_type(q)); del:=pyth_add(cur_x,cur_y);@/
  8396. dx2:=make_fraction(cur_x,del); dy2:=make_fraction(cur_y,del);
  8397.   {$\cos\theta_2$ and $\sin\theta_2$}
  8398. del:=take_fraction(dx1,dy2)-take_fraction(dx2,dy1); {$\sin(\theta_2-\theta_1)$}
  8399. if del>4684844 then clockwise:=false
  8400. else if del<-4684844 then clockwise:=true
  8401.   {$2^{28}\cdot\sin 1^\circ\approx4684844.68$}
  8402. else clockwise:=rev_turns;
  8403. @ Actually the turnarounds just computed will be clockwise,
  8404. not counterclockwise, if
  8405. the global variable |rev_turns| is |true|; it is usually |false|.
  8406. @<Glob...@>=
  8407. @!rev_turns:boolean; {should we make U-turns in the English manner?}
  8408. @ @<Set init...@>=
  8409. rev_turns:=false;
  8410. @ @<Compute the incoming and outgoing directions@>=
  8411. dx1:=x_coord(s)-left_x(s); dy1:=y_coord(s)-left_y(s);
  8412. if dx1=0 then if dy1=0 then
  8413.   begin dx1:=x_coord(s)-right_x(p); dy1:=y_coord(s)-right_y(p);
  8414.   if dx1=0 then if dy1=0 then
  8415.     begin dx1:=x_coord(s)-x_coord(p); dy1:=y_coord(s)-y_coord(p);
  8416.     end;  {and they {\sl can't} both be zero}
  8417.   end;
  8418. dmax:=abs(dx1);@+if abs(dy1)>dmax then dmax:=abs(dy1);
  8419. while dmax<fraction_one do
  8420.   begin double(dmax); double(dx1); double(dy1);
  8421.   end;
  8422. dx2:=right_x(q)-x_coord(q); dy2:=right_y(q)-y_coord(q);
  8423. if dx2=0 then if dy2=0 then
  8424.   begin dx2:=left_x(r)-x_coord(q); dy2:=left_y(r)-y_coord(q);
  8425.   if dx2=0 then if dy2=0 then
  8426.     begin if right_type(r)=endpoint then
  8427.       begin cur_x:=x_coord(r); cur_y:=y_coord(r);
  8428.       end
  8429.     else  begin unskew(x_coord(r),y_coord(r),right_type(r));
  8430.       skew(cur_x,cur_y,right_type(q));
  8431.       end;
  8432.     dx2:=cur_x-x_coord(q); dy2:=cur_y-y_coord(q);
  8433.     end;  {and they {\sl can't} both be zero}
  8434.   end;
  8435. dmax:=abs(dx2);@+if abs(dy2)>dmax then dmax:=abs(dy2);
  8436. while dmax<fraction_one do
  8437.   begin double(dmax); double(dx2); double(dy2);
  8438.   end
  8439. @ @<Insert additional boundary nodes...@>=
  8440. loop@+  begin if clockwise then
  8441.     if o1=1 then o1:=8@+else decr(o1)
  8442.   else if o1=8 then o1:=1@+else incr(o1);
  8443.   if o1=o2 then goto done;
  8444.   new_boundary(s,octant_code[o1]);
  8445.   s:=link(s); left_octant(s):=right_octant(s);
  8446.   end
  8447. @ Now it remains to insert the redundant
  8448. transition information into the |left_transition|
  8449. and |right_transition| fields between adjacent octants, in the octant
  8450. boundary nodes that have just been inserted between |link(p)| and~|q|.
  8451. The turning number is easily computed from these transitions.
  8452. @<Fix up the transition fields and adjust the turning number@>=
  8453. p:=link(p);
  8454. repeat s:=link(p);
  8455. o1:=octant_number[right_octant(p)]; o2:=octant_number[left_octant(s)];
  8456. if abs(o1-o2)=1 then
  8457.   begin if o2<o1 then o2:=o1;
  8458.   if odd(o2) then right_transition(p):=axis
  8459.   else right_transition(p):=diagonal;
  8460.   end
  8461. else  begin if o1=8 then incr(turning_number)@+else decr(turning_number);
  8462.   right_transition(p):=axis;
  8463.   end;
  8464. left_transition(s):=right_transition(p);
  8465. p:=s;
  8466. until p=q
  8467. @* \[22] Filling a contour.
  8468. Given the low-level machinery for making moves and for transforming a
  8469. cyclic path into a cycle spec, we're almost able to fill a digitized path.
  8470. All we need is a high-level routine that walks through the cycle spec and
  8471. controls the overall process.
  8472. Our overall goal is to plot the integer points $\bigl(\round(x(t)),
  8473. \round(y(t))\bigr)$ and to connect them by rook moves, assuming that
  8474. $\round(x(t))$ and $\round(y(t))$ don't both jump simultaneously from
  8475. one integer to another as $t$~varies; these rook moves will be the edge
  8476. of the contour that will be filled. We have reduced this problem to the
  8477. case of curves that travel in first octant directions, i.e., curves
  8478. such that $0\L y'(t)\L x'(t)$, by transforming the original coordinates.
  8479. \def\xtilde{{\tilde x}} \def\ytilde{{\tilde y}}
  8480. Another transformation makes the problem still simpler. We shall say that
  8481. we are working with {\sl biased coordinates\/} when $(x,y)$ has been
  8482. replaced by $(\xtilde,\ytilde)=(x-y,y+{1\over2})$. When a curve travels
  8483. in first octant directions, the corresponding curve with biased
  8484. coordinates travels in first {\sl quadrant\/} directions; the latter
  8485. condition is symmetric in $x$ and~$y$, so it has advantages for the
  8486. design of algorithms. The |make_spec| routine gives us skewed coordinates
  8487. $(x-y,y)$, hence we obtain biased coordinates by simply adding $1\over2$
  8488. to the second component.
  8489. The most important fact about biased coordinates is that we can determine the
  8490. rounded unbiased path $\bigl(\round(x(t)),\round(y(t))\bigr)$ from the
  8491. truncated biased path $\bigl(\lfloor\xtilde(t)\rfloor,\lfloor\ytilde(t)\rfloor
  8492. \bigr)$ and information about the initial and final endpoints. If the
  8493. unrounded and unbiased
  8494. path begins at $(x_0,y_0)$ and ends at $(x_1,y_1)$, it's possible to
  8495. prove (by induction on the length of truncated biased path) that the
  8496. rounded unbiased path is obtained by the following construction:
  8497. \yskip\textindent{1)} Start at $\bigl(\round(x_0),\round(y_0)\bigr)$.
  8498. \yskip\textindent{2)} If $(x_0+{1\over2})\bmod1\G(y_0+{1\over2})\bmod1$,
  8499. move one step right.
  8500. \yskip\textindent{3)} Whenever the path
  8501. $\bigl(\lfloor\xtilde(t)\rfloor,\lfloor\ytilde(t)\rfloor\bigr)$
  8502. takes an upward step (i.e., when
  8503. $\lfloor\xtilde(t+\epsilon)\rfloor=\lfloor\xtilde(t)\rfloor$ and
  8504. $\lfloor\ytilde(t+\epsilon)\rfloor=\lfloor\ytilde(t)\rfloor+1$),
  8505. move one step up and then one step right.
  8506. \yskip\textindent{4)} Whenever the path
  8507. $\bigl(\lfloor\xtilde(t)\rfloor,\lfloor\ytilde(t)\rfloor\bigr)$
  8508. takes a rightward step (i.e., when
  8509. $\lfloor\xtilde(t+\epsilon)\rfloor=\lfloor\xtilde(t)\rfloor+1$ and
  8510. $\lfloor\ytilde(t+\epsilon)\rfloor=\lfloor\ytilde(t)\rfloor$),
  8511. move one step right.
  8512. \yskip\textindent{5)} Finally, if
  8513. $(x_1+{1\over2})\bmod1\G(y_1+{1\over2})\bmod1$, move one step left (thereby
  8514. cancelling the previous move, which was one step right). You will now be
  8515. at the point $\bigl(\round(x_1),\round(y_1)\bigr)$.
  8516. @ In order to validate the assumption that $\round(x(t))$ and $\round(y(t))$
  8517. don't both jump simultaneously, we shall consider that a coordinate pair
  8518. $(x,y)$ actually represents $(x+\epsilon,y+\epsilon\delta)$, where
  8519. $\epsilon$ and $\delta$ are extremely small positive numbers---so small
  8520. that their precise values never matter.  This convention makes rounding
  8521. unambiguous, since there is always a unique integer point nearest to any
  8522. given scaled numbers~$(x,y)$.
  8523. When coordinates are transformed so that \MF\ needs to work only in ``first
  8524. octant'' directions, the transformations involve negating~$x$, negating~$y$,
  8525. and/or interchanging $x$ with~$y$. Corresponding adjustments to the
  8526. rounding conventions must be made so that consistent values will be
  8527. obtained. For example, suppose that we're working with coordinates that
  8528. have been transformed so that a third-octant curve travels in first-octant
  8529. directions. The skewed coordinates $(x,y)$ in our data structure represent
  8530. unskewed coordinates $(-y,x+y)$, which are actually $-y+\epsilon,
  8531. x+y+\epsilon\delta$. We should therefore round as if our skewed coordinates
  8532. were $(x+\epsilon+\epsilon\delta,y-\epsilon)$ instead of $(x,y)$. The following
  8533. table shows how the skewed coordinates should be perturbed when rounding
  8534. decisions are made:
  8535. $$\vcenter{\halign{#\hfil&&\quad$#$\hfil&\hskip4em#\hfil\cr
  8536. |first_octant|&(x+\epsilon-\epsilon\delta,y+\epsilon\delta)&
  8537.  |fifth_octant|&(x-\epsilon+\epsilon\delta,y-\epsilon\delta)\cr
  8538. |second_octant|&(x-\epsilon+\epsilon\delta,y+\epsilon)&
  8539.  |sixth_octant|&(x+\epsilon-\epsilon\delta,y-\epsilon)\cr
  8540. |third_octant|&(x+\epsilon+\epsilon\delta,y-\epsilon)&
  8541.  |seventh_octant|&(x-\epsilon-\epsilon\delta,y+\epsilon)\cr
  8542. |fourth_octant|&(x-\epsilon-\epsilon\delta,y+\epsilon\delta)&
  8543.  |eighth_octant|&(x+\epsilon+\epsilon\delta,y-\epsilon\delta)\cr}}$$
  8544. Four small arrays are set up so that the rounding operations will be
  8545. fairly easy in any given octant.
  8546. @<Glob...@>=
  8547. @!y_corr,@!xy_corr,@!z_corr:array[first_octant..sixth_octant] of 0..1;
  8548. @!x_corr:array[first_octant..sixth_octant] of -1..1;
  8549. @ Here |xy_corr| is 1 if and only if the $x$ component of a skewed coordinate
  8550. is to be decreased by an infinitesimal amount; |y_corr| is similar, but for
  8551. the $y$ components. The other tables are set up so that the condition
  8552. $$(x+y+|half_unit|)\bmod|unity|\G(y+|half_unit|)\bmod|unity|$$
  8553. is properly perturbed to the condition
  8554. $$(x+y+|half_unit|-|x_corr|-|y_corr|)\bmod|unity|\G
  8555.   (y+|half_unit|-|y_corr|)\bmod|unity|+|z_corr|.$$
  8556. @<Set init...@>=
  8557. x_corr[first_octant]:=0; y_corr[first_octant]:=0;
  8558. xy_corr[first_octant]:=0;@/
  8559. x_corr[second_octant]:=0; y_corr[second_octant]:=0;
  8560. xy_corr[second_octant]:=1;@/
  8561. x_corr[third_octant]:=-1; y_corr[third_octant]:=1;
  8562. xy_corr[third_octant]:=0;@/
  8563. x_corr[fourth_octant]:=1; y_corr[fourth_octant]:=0;
  8564. xy_corr[fourth_octant]:=1;@/
  8565. x_corr[fifth_octant]:=0; y_corr[fifth_octant]:=1;
  8566. xy_corr[fifth_octant]:=1;@/
  8567. x_corr[sixth_octant]:=0; y_corr[sixth_octant]:=1;
  8568. xy_corr[sixth_octant]:=0;@/
  8569. x_corr[seventh_octant]:=1; y_corr[seventh_octant]:=0;
  8570. xy_corr[seventh_octant]:=1;@/
  8571. x_corr[eighth_octant]:=-1; y_corr[eighth_octant]:=1;
  8572. xy_corr[eighth_octant]:=0;@/
  8573. for k:=1 to 8 do z_corr[k]:=xy_corr[k]-x_corr[k];
  8574. @ Here's a procedure that handles the details of rounding at the
  8575. endpoints: Given skewed coordinates |(x,y)|, it sets |(m1,n1)|
  8576. to the corresponding rounded lattice points, taking the current
  8577. |octant| into account. Global variable |d1| is also set to 1 if
  8578. $(x+y+{1\over2})\bmod1\G(y+{1\over2})\bmod1$.
  8579. @p procedure end_round(@!x,@!y:scaled);
  8580. begin y:=y+half_unit-y_corr[octant];
  8581. x:=x+y-x_corr[octant];
  8582. m1:=floor_unscaled(x); n1:=floor_unscaled(y);
  8583. if x-unity*m1>=y-unity*n1+z_corr[octant] then d1:=1@+else d1:=0;
  8584. @ The outputs |(m1,n1,d1)| of |end_round| will sometimes be moved
  8585. to |(m0,n0,d0)|.
  8586. @<Glob...@>=
  8587. @!m0,@!n0,@!m1,@!n1:integer; {lattice point coordinates}
  8588. @!d0,@!d1:0..1; {displacement corrections}
  8589. @ We're ready now to fill the pixels enclosed by a given cycle spec~|h|;
  8590. the knot list that represents the cycle is destroyed in the process.
  8591. The edge structure that gets all the resulting data is |cur_edges|,
  8592. and the edges are weighted by |cur_wt|.
  8593. @p procedure fill_spec(@!h:pointer);
  8594. var @!p,@!q,@!r,@!s:pointer; {for list traversal}
  8595. begin if internal[tracing_edges]>0 then begin_edge_tracing;
  8596. p:=h; {we assume that |left_type(h)=endpoint|}
  8597. repeat octant:=left_octant(p);
  8598. @<Set variable |q| to the node at the end of the current octant@>;
  8599. if q<>p then
  8600.   begin @<Determine the starting and ending
  8601.     lattice points |(m0,n0)| and |(m1,n1)|@>;
  8602.   @<Make the moves for the current octant@>;
  8603.   move_to_edges(m0,n0,m1,n1);
  8604.   end;
  8605. p:=link(q);
  8606. until p=h;
  8607. toss_knot_list(h);
  8608. if internal[tracing_edges]>0 then end_edge_tracing;
  8609. @ @<Set variable |q| to the node at the end of the current octant@>=
  8610. q:=p;
  8611. while right_type(q)<>endpoint do q:=link(q)
  8612. @ @<Determine the starting and ending lattice points |(m0,n0)| and |(m1,n1)|@>=
  8613. end_round(x_coord(p),y_coord(p)); m0:=m1; n0:=n1; d0:=d1;@/
  8614. end_round(x_coord(q),y_coord(q))
  8615. @ Finally we perform the five-step process that was explained at
  8616. the very beginning of this part of the program.
  8617. @<Make the moves for the current octant@>=
  8618. if n1-n0>=move_size then overflow("move table size",move_size);
  8619. @:METAFONT capacity exceeded move table size}{\quad move table size@>
  8620. move[0]:=d0; move_ptr:=0; r:=p;
  8621. repeat s:=link(r);@/
  8622. make_moves(x_coord(r),right_x(r),left_x(s),x_coord(s),@|
  8623.   y_coord(r)+half_unit,right_y(r)+half_unit,left_y(s)+half_unit,
  8624.   y_coord(s)+half_unit,@| xy_corr[octant],y_corr[octant]);
  8625. r:=s;
  8626. until r=q;
  8627. move[move_ptr]:=move[move_ptr]-d1;
  8628. if internal[smoothing]>0 then smooth_moves(0,move_ptr)
  8629. @* \[23] Polygonal pens.
  8630. The next few parts of the program deal with the additional complications
  8631. associated with ``envelopes,'' leading up to an algorithm that fills a
  8632. contour with respect to a pen whose boundary is a convex polygon. The
  8633. mathematics underlying this algorithm is based on simple aspects of the
  8634. theory of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge
  8635. Stolfi [``A kinetic framework for computational geometry,''
  8636. {\sl Proc.\ IEEE Symp.\ Foundations of Computer Science\/ \bf24} (1983),
  8637. 100--111].
  8638. @^Guibas, Leonidas Ioannis@>
  8639. @^Ramshaw, Lyle Harold@>
  8640. @^Stolfi, Jorge@>
  8641. If the vertices of the polygon are $w_0$, $w_1$, \dots, $w_{n-1}$, $w_n=w_0$,
  8642. in counterclockwise order, the convexity condition requires that ``left
  8643. turns'' are made at each vertex when a person proceeds from $w_0$ to
  8644. $w_1$ to $\cdots$ to~$w_n$. The envelope is obtained if we offset a given
  8645. curve $z(t)$ by $w_k$ when that curve is traveling in a direction
  8646. $z'(t)$ lying between the directions $w_k-w_{k-1}$ and $w\k-w_k$.
  8647. At times~$t$ when the curve direction $z'(t)$ increases past
  8648. $w\k-w_k$, we temporarily stop plotting the offset curve and we insert
  8649. a straight line from $z(t)+w_k$ to $z(t)+w\k$; notice that this straight
  8650. line is tangent to the offset curve. Similarly, when the curve direction
  8651. decreases past $w_k-w_{k-1}$, we stop plotting and insert a straight
  8652. line from $z(t)+w_k$ to $z(t)+w_{k-1}$; the latter line is actually a
  8653. ``retrograde'' step, which won't be part of the final envelope under
  8654. \MF's assumptions. The result of this construction is a continuous path
  8655. that consists of alternating curves and straight line segments. The
  8656. segments are usually so short, in practice, that they blend with the
  8657. curves; after all, it's possible to represent any digitized path as
  8658. a sequence of digitized straight lines.
  8659. The nicest feature of this approach to envelopes is that it blends
  8660. perfectly with the octant subdivision process we have already developed.
  8661. The envelope travels in the same direction as the curve itself, as we
  8662. plot it, and we need merely be careful what offset is being added.
  8663. Retrograde motion presents a problem, but we will see that there is
  8664. a decent way to handle it.
  8665. @ We shall represent pens by maintaining eight lists of offsets,
  8666. one for each octant direction. The offsets at the boundary points
  8667. where a curve turns into a new octant will appear in the lists for
  8668. both octants. This means that we can restrict consideration to
  8669. segments of the original polygon whose directions aim in the first
  8670. octant, as we have done in the simpler case when envelopes were not
  8671. required.
  8672. An example should help to clarify this situation: Consider the
  8673. quadrilateral whose vertices are $w_0=(0,-1)$, $w_1=(3,-1)$,
  8674. $w_2=(6,1)$, and $w_3=(1,2)$. A curve that travels in the first octant
  8675. will be offset by $w_1$ or $w_2$, unless its slope drops to zero
  8676. en route to the eighth octant; in the latter case we should switch to $w_0$ as
  8677. we cross the octant boundary. Our list for the first octant will
  8678. contain the three offsets $w_0$, $w_1$,~$w_2$. By convention we will
  8679. duplicate a boundary offset if the angle between octants doesn't
  8680. explicitly appear; in this case there is no explicit line of slope~1
  8681. at the end of the list, so the full list is
  8682. $$w_0\;w_1\;w_2\;w_2\;=\;(0,-1)\;(3,-1)\;(6,1)\;(6,1).$$
  8683. With skewed coordinates $(u-v,v)$ instead of $(u,v)$ we obtain the list
  8684. $$w_0\;w_1\;w_2\;w_2\;\mapsto\;(1,-1)\;(4,-1)\;(5,1)\;(5,1),$$
  8685. which is what actually appears in the data structure. In the second
  8686. octant there's only one offset; we list it three times (with coordinates
  8687. interchanged, so as to make the second octant look like the first),
  8688. and skew those coordinates, obtaining
  8689. $$\tabskip\centering
  8690. \halign to\hsize{$\hfil#\;\mapsto\;{}$\tabskip=0pt&
  8691.   $#\hfil$&\quad in the #\hfil\tabskip\centering\cr
  8692. w_2\;w_2\;w_2&(-5,6)\;(-5,6)\;(-5,6)\cr
  8693. \noalign{\vskip\belowdisplayskip
  8694. \vbox{\noindent\strut as the list of transformed and skewed offsets to use
  8695. when curves that travel in the second octant. Similarly, we will have\strut}
  8696. \vskip\abovedisplayskip}
  8697. w_2\;w_2\;w_2&(7,-6)\;(7,-6)\;(7,-6)&third;\cr
  8698. w_2\;w_2\;w_3\;w_3&(-7,1)\;(-7,1)\;(-3,2)\;(-3,2)&fourth;\cr
  8699. w_3\;w_3\;w_3&(3,-2)\;(3,-2)\;(3,-2)&fifth;\cr
  8700. w_3\;w_3\;w_0\;w_0&(-3,1)\;(-3,1)\;(1,0)\;(1,0)&sixth;\cr
  8701. w_0\;w_0\;w_0&(1,0)\;(1,0)\;(1,0)&seventh;\cr
  8702. w_0\;w_0\;w_0&(-1,1)\;(-1,1)\;(-1,1)&eighth.\cr}$$
  8703. Notice that $w_1$ is considered here to be internal to the first octant;
  8704. it's not part of the eighth. We could equally well have taken $w_0$ out
  8705. of the first octant list and put it into the eighth; then the first octant
  8706. list would have been
  8707. $$w_1\;w_1\;w_2\;w_2\;\mapsto\;(4,-1)\;(4,-1)\;(5,1)\;(5,1)$$
  8708. and the eighth octant list would have been
  8709. $$w_0\;w_0\;w_1\;\mapsto\;(-1,1)\;(-1,1)\;(2,1).$$
  8710. Actually, there's one more complication: The order of offsets is reversed
  8711. in even-numbered octants, because the transformation of coordinates has
  8712. reversed counterclockwise and clockwise orientations in those octants.
  8713. The offsets in the fourth octant, for example, are really $w_3$, $w_3$,
  8714. $w_2$,~$w_2$, not $w_2$, $w_2$, $w_3$,~$w_3$.
  8715. @ In general, the list of offsets for an octant will have the form
  8716. $$w_0\;\;w_1\;\;\ldots\;\;w_n\;\;w_{n+1}$$
  8717. (if we renumber the subscripts in each list), where $w_0$ and $w_{n+1}$
  8718. are offsets common to the neighboring lists. We'll often have $w_0=w_1$
  8719. and/or $w_n=w_{n+1}$, but the other $w$'s will be distinct. Curves
  8720. that travel between slope~0 and direction $w_2-w_1$ will use offset~$w_1$;
  8721. curves that travel between directions $w_k-w_{k-1}$ and $w\k-w_k$ will
  8722. use offset~$w_k$, for $1<k<n$; curves between direction $w_n-w_{n-1}$
  8723. and slope~1 (actually slope~$\infty$ after skewing) will use offset~$w_n$.
  8724. In even-numbered octants, the directions are actually $w_k-w\k$ instead
  8725. of $w\k-w_k$, because the offsets have been listed in reverse order.
  8726. Each offset $w_k$ is represented by skewed coordinates $(u_k-v_k,v_k)$,
  8727. where $(u_k,v_k)$ is the representation of $w_k$ after it has been rotated
  8728. into a first-octant disguise.
  8729. @ The top-level data structure of a pen polygon is a 10-word node containing
  8730. a reference count followed by pointers to the eight pen lists, followed
  8731. by an indication of the pen's range of values.
  8732. If |p|~points to such a node, and if the
  8733. offset list for, say, the fourth octant has entries $w_0$, $w_1$, \dots,
  8734. $w_n$,~$w_{n+1}$, then |info(p+fourth_octant)| will equal~$n$, and
  8735. |link(p+fourth_octant)| will point to the offset node containing~$w_0$.
  8736. Memory location |p+fourth_octant| is said to be the {\sl header\/} of
  8737. the pen-offset list for the fourth octant. Since this is an even-numbered
  8738. octant, $w_0$ is the offset that goes with the fifth octant, and
  8739. $w_{n+1}$ goes with the third.
  8740. The elements of the offset list themselves are doubly linked 3-word nodes,
  8741. containing coordinates in their |x_coord| and |y_coord| fields.
  8742. The two link fields are called |link| and |knil|; if |w|~points to
  8743. the node for~$w_k$, then |link(w)| and |knil(w)| point respectively
  8744. to the nodes for $w\k$ and~$w_{k-1}$. If |h| is the list header,
  8745. |link(h)| points to the node for~$w_0$ and |knil(link(h))| to the
  8746. node for~$w_{n+1}$.
  8747. The tenth word of a pen header node contains the maximum absolute value of
  8748. an $x$ or $y$ coordinate among all of the unskewed pen offsets.
  8749. The |link| field of a pen header node should be |null| if and only if
  8750. the pen has no offsets.
  8751. @d pen_node_size=10
  8752. @d coord_node_size=3
  8753. @d max_offset(#)==mem[#+9].sc
  8754. @ The |print_pen| subroutine illustrates these conventions by
  8755. reconstructing the vertices of a polygon from \MF's complicated
  8756. internal offset representation.
  8757. @<Declare subroutines for printing expressions@>=
  8758. procedure print_pen(@!p:pointer;@!s:str_number;@!nuline:boolean);
  8759. var @!nothing_printed:boolean; {has there been any action yet?}
  8760. @!k:1..8; {octant number}
  8761. @!h:pointer; {offset list head}
  8762. @!m,@!n:integer; {offset indices}
  8763. @!w,@!ww:pointer; {pointers that traverse the offset list}
  8764. begin print_diagnostic("Pen polygon",s,nuline);
  8765. nothing_printed:=true; print_ln;
  8766. for k:=1 to 8 do
  8767.   begin octant:=octant_code[k]; h:=p+octant; n:=info(h); w:=link(h);
  8768.   if not odd(k) then w:=knil(w); {in even octants, start at $w_{n+1}$}
  8769.   for m:=1 to n+1 do
  8770.     begin if odd(k) then ww:=link(w)@+else ww:=knil(w);
  8771.     if (x_coord(ww)<>x_coord(w))or(y_coord(ww)<>y_coord(w)) then
  8772.       @<Print the unskewed and unrotated coordinates of node |ww|@>;
  8773.     w:=ww;
  8774.     end;
  8775.   end;
  8776. if nothing_printed then
  8777.   begin w:=link(p+first_octant); print_two(x_coord(w)+y_coord(w),y_coord(w));
  8778.   end;
  8779. print_nl(" .. cycle"); end_diagnostic(true);
  8780. @ @<Print the unskewed and unrotated coordinates of node |ww|@>=
  8781. begin if nothing_printed then nothing_printed:=false
  8782. else print_nl(" .. ");
  8783. print_two_true(x_coord(ww),y_coord(ww));
  8784. @ A null pen polygon, which has just one vertex $(0,0)$, is
  8785. predeclared for error recovery. It doesn't need a proper
  8786. reference count, because the |toss_pen| procedure below
  8787. will never delete it from memory.
  8788. @<Initialize table entries...@>=
  8789. ref_count(null_pen):=null; link(null_pen):=null;@/
  8790. info(null_pen+1):=1; link(null_pen+1):=null_coords;
  8791. for k:=null_pen+2 to null_pen+8 do mem[k]:=mem[null_pen+1];
  8792. max_offset(null_pen):=0;@/
  8793. link(null_coords):=null_coords;
  8794. knil(null_coords):=null_coords;@/
  8795. x_coord(null_coords):=0;
  8796. y_coord(null_coords):=0;
  8797. @ Here's a trivial subroutine that inserts a copy of an offset
  8798. on the |link| side of its clone in the doubly linked list.
  8799. @p procedure dup_offset(@!w:pointer);
  8800. var @!r:pointer; {the new node}
  8801. begin r:=get_node(coord_node_size);
  8802. x_coord(r):=x_coord(w);
  8803. y_coord(r):=y_coord(w);
  8804. link(r):=link(w); knil(link(w)):=r;
  8805. knil(r):=w; link(w):=r;
  8806. @ The following algorithm is somewhat more interesting: It converts a
  8807. knot list for a cyclic path into a pen polygon, ignoring everything
  8808. but the |x_coord|, |y_coord|, and |link| fields. If the given path
  8809. vertices do not define a convex polygon, an error message is issued
  8810. and the null pen is returned.
  8811. @p function make_pen(@!h:pointer):pointer;
  8812. label done,done1,not_found,found;
  8813. var @!o,@!oo,@!k:small_number; {octant numbers---old, new, and current}
  8814. @!p:pointer; {top-level node for the new pen}
  8815. @!q,@!r,@!s,@!w,@!hh:pointer; {for list manipulation}
  8816. @!n:integer; {offset counter}
  8817. @!dx,@!dy:scaled; {polygon direction}
  8818. @!mc:scaled; {the largest coordinate}
  8819. begin @<Stamp all nodes with an octant code, compute the maximum offset,
  8820.   and set |hh| to the node that begins the first octant;
  8821.   |goto not_found| if there's a problem@>;
  8822. if mc>=fraction_one-half_unit then goto not_found;
  8823. p:=get_node(pen_node_size); q:=hh; max_offset(p):=mc; ref_count(p):=null;
  8824. if link(q)<>q then link(p):=null+1;
  8825. for k:=1 to 8 do @<Construct the offset list for the |k|th octant@>;
  8826. goto found;
  8827. not_found:p:=null_pen; @<Complain about a bad pen path@>;
  8828. found: if internal[tracing_pens]>0 then print_pen(p," (newly created)",true);
  8829. make_pen:=p;
  8830. @ @<Complain about a bad pen path@>=
  8831. if mc>=fraction_one-half_unit then
  8832.   begin print_err("Pen too large");
  8833. @.Pen too large@>
  8834.   help2("The cycle you specified has a coordinate of 4095.5 or more.")@/
  8835.   ("So I've replaced it by the trivial path `(0,0)..cycle'.");@/
  8836.   end
  8837. else  begin print_err("Pen cycle must be convex");
  8838. @.Pen cycle must be convex@>
  8839.   help3("The cycle you specified either has consecutive equal points")@/
  8840.     ("or turns right or turns through more than 360 degrees.")@/
  8841.   ("So I've replaced it by the trivial path `(0,0)..cycle'.");@/
  8842.   end;
  8843. put_get_error
  8844. @ There should be exactly one node whose octant number is less than its
  8845. predecessor in the cycle; that is node~|hh|.
  8846. The loop here will terminate in all cases, but the proof is somewhat tricky:
  8847. If there are at least two distinct $y$~coordinates in the cycle, we will have
  8848. |o>4| and |o<=4| at different points of the cycle. Otherwise there are
  8849. at least two distinct $x$~coordinates, and we will have |o>2| somewhere,
  8850. |o<=2| somewhere.
  8851. @<Stamp all nodes...@>=
  8852. q:=h; r:=link(q); mc:=abs(x_coord(h));
  8853. if q=r then
  8854.   begin hh:=h; right_type(h):=0; {this trick is explained below}
  8855.   if mc<abs(y_coord(h)) then mc:=abs(y_coord(h));
  8856.   end
  8857. else  begin o:=0; hh:=null;
  8858.   loop@+  begin s:=link(r);
  8859.     if mc<abs(x_coord(r)) then mc:=abs(x_coord(r));
  8860.     if mc<abs(y_coord(r)) then mc:=abs(y_coord(r));
  8861.     dx:=x_coord(r)-x_coord(q); dy:=y_coord(r)-y_coord(q);
  8862.     if dx=0 then if dy=0 then goto not_found; {double point}
  8863.     if ab_vs_cd(dx,y_coord(s)-y_coord(r),dy,x_coord(s)-x_coord(r))<0 then
  8864.       goto not_found; {right turn}
  8865.     @<Determine the octant code for direction |(dx,dy)|@>;
  8866.     right_type(q):=octant; oo:=octant_number[octant];
  8867.     if o>oo then
  8868.       begin if hh<>null then goto not_found; {$>360^\circ$}
  8869.       hh:=q;
  8870.       end;
  8871.     o:=oo;
  8872.     if (q=h)and(hh<>null) then goto done;
  8873.     q:=r; r:=s;
  8874.     end;
  8875.   done:end
  8876. @ We want the octant for |(-dx,-dy)| to be
  8877. exactly opposite the octant for |(dx,dy)|.
  8878. @<Determine the octant code for direction |(dx,dy)|@>=
  8879. if dx>0 then octant:=first_octant
  8880. else if dx=0 then
  8881.   if dy>0 then octant:=first_octant@+else octant:=first_octant+negate_x
  8882. else  begin negate(dx); octant:=first_octant+negate_x;
  8883.   end;
  8884. if dy<0 then
  8885.   begin negate(dy); octant:=octant+negate_y;
  8886.   end
  8887. else if dy=0 then
  8888.   if octant>first_octant then octant:=first_octant+negate_x+negate_y;
  8889. if dx<dy then octant:=octant+switch_x_and_y
  8890. @ Now |q| points to the node that the present octant shares with the previous
  8891. octant, and |right_type(q)| is the octant code during which |q|~should advance.
  8892. We have set |right_type(q)=0| in the special case that |q| should never advance
  8893. (because the pen is degenerate).
  8894. The number of offsets |n| must be smaller than |max_quarterword|, because
  8895. the |fill_envelope| routine stores |n+1| in the |right_type| field
  8896. of a knot node.
  8897. @<Construct the offset list...@>=
  8898. begin octant:=octant_code[k]; n:=0; h:=p+octant;
  8899. loop@+  begin r:=get_node(coord_node_size);
  8900.   skew(x_coord(q),y_coord(q),octant); x_coord(r):=cur_x; y_coord(r):=cur_y;
  8901.   if n=0 then link(h):=r
  8902.   else  @<Link node |r| to the previous node@>;
  8903.   w:=r;
  8904.   if right_type(q)<>octant then goto done1;
  8905.   q:=link(q); incr(n);
  8906.   end;
  8907. done1: @<Finish linking the offset nodes, and duplicate the
  8908.   borderline offset nodes if necessary@>;
  8909. if n>=max_quarterword then overflow("pen polygon size",max_quarterword);
  8910. @:METAFONT capacity exceeded pen polygon size}{\quad pen polygon size@>
  8911. info(h):=n;
  8912. @ Now |w| points to the node that was inserted most recently, and
  8913. |k| is the current octant number.
  8914. @<Link node |r| to the previous node@>=
  8915. if odd(k) then
  8916.   begin link(w):=r; knil(r):=w;
  8917.   end
  8918. else  begin knil(w):=r; link(r):=w;
  8919.   end
  8920. @ We have inserted |n+1| nodes; it remains to duplicate the nodes at the
  8921. ends, if slopes 0 and~$\infty$ aren't already represented. At the end of
  8922. this section the total number of offset nodes should be |n+2|
  8923. (since we call them $w_0$, $w_1$, \dots,~$w_{n+1}$).
  8924. @<Finish linking the offset nodes, and duplicate...@>=
  8925. r:=link(h);
  8926. if odd(k) then
  8927.   begin link(w):=r; knil(r):=w;
  8928.   end
  8929. else  begin knil(w):=r; link(r):=w; link(h):=w; r:=w;
  8930.   end;
  8931. if (y_coord(r)<>y_coord(link(r)))or(n=0) then
  8932.   begin dup_offset(r); incr(n);
  8933.   end;
  8934. r:=knil(r);
  8935. if x_coord(r)<>x_coord(knil(r)) then dup_offset(r)
  8936. else decr(n)
  8937. @ Conversely, |make_path| goes back from a pen to a cyclic path that
  8938. might have generated it. The structure of this subroutine is essentially
  8939. the same as |print_pen|.
  8940. @p @t\4@>@<Declare the function called |trivial_knot|@>@;
  8941. function make_path(@!pen_head:pointer):pointer;
  8942. var @!p:pointer; {the most recently copied knot}
  8943. @!k:1..8; {octant number}
  8944. @!h:pointer; {offset list head}
  8945. @!m,@!n:integer; {offset indices}
  8946. @!w,@!ww:pointer; {pointers that traverse the offset list}
  8947. begin p:=temp_head;
  8948. for k:=1 to 8 do
  8949.   begin octant:=octant_code[k]; h:=pen_head+octant; n:=info(h); w:=link(h);
  8950.   if not odd(k) then w:=knil(w); {in even octants, start at $w_{n+1}$}
  8951.   for m:=1 to n+1 do
  8952.     begin if odd(k) then ww:=link(w)@+else ww:=knil(w);
  8953.     if (x_coord(ww)<>x_coord(w))or(y_coord(ww)<>y_coord(w)) then
  8954.       @<Copy the unskewed and unrotated coordinates of node |ww|@>;
  8955.     w:=ww;
  8956.     end;
  8957.   end;
  8958. if p=temp_head then
  8959.   begin w:=link(pen_head+first_octant);
  8960.   p:=trivial_knot(x_coord(w)+y_coord(w),y_coord(w)); link(temp_head):=p;
  8961.   end;
  8962. link(p):=link(temp_head); make_path:=link(temp_head);
  8963. @ @<Copy the unskewed and unrotated coordinates of node |ww|@>=
  8964. begin unskew(x_coord(ww),y_coord(ww),octant);
  8965. link(p):=trivial_knot(cur_x,cur_y); p:=link(p);
  8966. @ @<Declare the function called |trivial_knot|@>=
  8967. function trivial_knot(@!x,@!y:scaled):pointer;
  8968. var @!p:pointer; {a new knot for explicit coordinates |x| and |y|}
  8969. begin p:=get_node(knot_node_size);
  8970. left_type(p):=explicit; right_type(p):=explicit;@/
  8971. x_coord(p):=x; left_x(p):=x; right_x(p):=x;@/
  8972. y_coord(p):=y; left_y(p):=y; right_y(p):=y;@/
  8973. trivial_knot:=p;
  8974. @ That which can be created can be destroyed.
  8975. @d add_pen_ref(#)==incr(ref_count(#))
  8976. @d delete_pen_ref(#)==if ref_count(#)=null then toss_pen(#)
  8977.   else decr(ref_count(#))
  8978. @<Declare the recycling subroutines@>=
  8979. procedure toss_pen(@!p:pointer);
  8980. var @!k:1..8; {relative header locations}
  8981. @!w,@!ww:pointer; {pointers to offset nodes}
  8982. begin if p<>null_pen then
  8983.   begin for k:=1 to 8 do
  8984.     begin w:=link(p+k);
  8985.     repeat ww:=link(w); free_node(w,coord_node_size); w:=ww;
  8986.     until w=link(p+k);
  8987.     end;
  8988.   free_node(p,pen_node_size);
  8989.   end;
  8990. @ The |find_offset| procedure sets |(cur_x,cur_y)| to the offset associated
  8991. with a given direction~|(x,y)| and a given pen~|p|. If |x=y=0|, the
  8992. result is |(0,0)|. If two different offsets apply, one of them is
  8993. chosen arbitrarily.
  8994. @p procedure find_offset(@!x,@!y:scaled; @!p:pointer);
  8995. label done,exit;
  8996. var @!octant:first_octant..sixth_octant; {octant code for |(x,y)|}
  8997. @!s:-1..+1; {sign of the octant}
  8998. @!n:integer; {number of offsets remaining}
  8999. @!h,@!w,@!ww:pointer; {list traversal registers}
  9000. begin @<Compute the octant code; skew and rotate the coordinates |(x,y)|@>;
  9001. if odd(octant_number[octant]) then s:=-1@+else s:=+1;
  9002. h:=p+octant; w:=link(link(h)); ww:=link(w); n:=info(h);
  9003. while n>1 do
  9004.   begin if ab_vs_cd(x,y_coord(ww)-y_coord(w),@|
  9005.     y,x_coord(ww)-x_coord(w))<>s then goto done;
  9006.   w:=ww; ww:=link(w); decr(n);
  9007.   end;
  9008. done:unskew(x_coord(w),y_coord(w),octant);
  9009. exit:end;
  9010. @ @<Compute the octant code; skew and rotate the coordinates |(x,y)|@>=
  9011. if x>0 then octant:=first_octant
  9012. else if x=0 then
  9013.   if y<=0 then
  9014.     if y=0 then
  9015.       begin cur_x:=0; cur_y:=0; return;
  9016.       end
  9017.     else octant:=first_octant+negate_x
  9018.   else octant:=first_octant
  9019. else  begin x:=-x;
  9020.   if y=0 then octant:=first_octant+negate_x+negate_y
  9021.   else octant:=first_octant+negate_x;
  9022.   end;
  9023. if y<0 then
  9024.   begin octant:=octant+negate_y; y:=-y;
  9025.   end;
  9026. if x>=y then x:=x-y
  9027. else  begin octant:=octant+switch_x_and_y; x:=y-x; y:=y-x;
  9028.   end
  9029. @* \[24] Filling an envelope.
  9030. We are about to reach the culmination of \MF's digital plotting routines:
  9031. Almost all of the previous algorithms will be brought to bear on \MF's
  9032. most difficult task, which is to fill the envelope of a given cyclic path
  9033. with respect to a given pen polygon.
  9034. But we still must complete some of the preparatory work before taking such
  9035. a big plunge.
  9036. @ Given a pointer |c| to a nonempty list of cubics,
  9037. and a pointer~|h| to the header information of a pen polygon segment,
  9038. the |offset_prep| routine changes the list into cubics that are
  9039. associated with particular pen offsets. Namely, the cubic between |p|
  9040. and~|q| should be associated with the |k|th offset when |right_type(p)=k|.
  9041. List |c| is actually part of a cycle spec, so it terminates at the
  9042. first node whose |right_type| is |endpoint|. The cubics all have
  9043. monotone-nondecreasing $x'(t)$ and $y'(t)$.
  9044. @p @t\4@>@<Declare subroutines needed by |offset_prep|@>@;
  9045. procedure offset_prep(@!c,@!h:pointer);
  9046. label done,not_found;
  9047. var @!n:halfword; {the number of pen offsets}
  9048. @!p,@!q,@!r,@!lh,@!ww:pointer; {for list manipulation}
  9049. @!k:halfword; {the current offset index}
  9050. @!w:pointer; {a pointer to offset $w_k$}
  9051. @<Other local variables for |offset_prep|@>@;
  9052. begin p:=c; n:=info(h); lh:=link(h); {now |lh| points to $w_0$}
  9053. while right_type(p)<>endpoint do
  9054.   begin q:=link(p);
  9055.   @<Split the cubic between |p| and |q|, if necessary, into cubics
  9056.     associated with single offsets, after which |q| should
  9057.     point to the end of the final such cubic@>;
  9058.   @<Advance |p| to node |q|, removing any ``dead'' cubics that
  9059.     might have been introduced by the splitting process@>;
  9060.   end;
  9061. @ @<Advance |p| to node |q|, removing any ``dead'' cubics...@>=
  9062. repeat r:=link(p);
  9063. if x_coord(p)=right_x(p) then if y_coord(p)=right_y(p) then
  9064.  if x_coord(p)=left_x(r) then if y_coord(p)=left_y(r) then
  9065.   if x_coord(p)=x_coord(r) then if y_coord(p)=y_coord(r) then
  9066.   begin remove_cubic(p);
  9067.   if r=q then q:=p;
  9068.   r:=p;
  9069.   end;
  9070. p:=r;
  9071. until p=q
  9072. @ The splitting process uses a subroutine like |split_cubic|, but
  9073. (for ``bulletproof'' operation) we check to make sure that the
  9074. resulting (skewed) coordinates satisfy $\Delta x\G0$ and $\Delta y\G0$
  9075. after splitting; |make_spec| has made sure that these relations hold
  9076. before splitting. (This precaution is surely unnecessary, now that
  9077. |make_spec| is so much more careful than it used to be. But who
  9078. wants to take a chance? Maybe the hardware will fail or something.)
  9079. @<Declare subroutines needed by |offset_prep|@>=
  9080. procedure split_for_offset(@!p:pointer;@!t:fraction);
  9081. var @!q:pointer; {the successor of |p|}
  9082. @!r:pointer; {the new node}
  9083. begin q:=link(p); split_cubic(p,t,x_coord(q),y_coord(q)); r:=link(p);
  9084. if y_coord(r)<y_coord(p) then y_coord(r):=y_coord(p)
  9085. else if y_coord(r)>y_coord(q) then y_coord(r):=y_coord(q);
  9086. if x_coord(r)<x_coord(p) then x_coord(r):=x_coord(p)
  9087. else if x_coord(r)>x_coord(q) then x_coord(r):=x_coord(q);
  9088. @ If the pen polygon has |n| offsets, and if $w_k=(u_k,v_k)$ is the $k$th
  9089. of these, the $k$th pen slope is defined by the formula
  9090. $$s_k={v\k-v_k\over u\k-u_k},\qquad\hbox{for $0<k<n$}.$$
  9091. In odd-numbered octants, the numerator and denominator of this fraction
  9092. will be positive; in even-numbered octants they will both be negative.
  9093. Furthermore we always have $0=s_0<s_1<\cdots<s_n=\infty$. The goal of
  9094. |offset_prep| is to find an offset index~|k| to associate with
  9095. each cubic, such that the slope $s(t)$ of the cubic satisfies
  9096. $$s_{k-1}\le s(t)\le s_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$
  9097. We may have to split a cubic into as many as $2n-1$ pieces before each
  9098. piece corresponds to a unique offset.
  9099. @<Split the cubic between |p| and |q|, if necessary, into cubics...@>=
  9100. if n<=1 then right_type(p):=1 {this case is easy}
  9101. else  begin @<Prepare for derivative computations;
  9102.     |goto not_found| if the current cubic is dead@>;
  9103.   @<Find the initial slope, |dy/dx|@>;
  9104.   if dx=0 then @<Handle the special case of infinite slope@>
  9105.   else  begin @<Find the index |k| such that $s_{k-1}\L\\{dy}/\\{dx}<s_k$@>;
  9106.     @<Complete the offset splitting process@>;
  9107.     end;
  9108. not_found: end
  9109. @ The slope of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be
  9110. calculated from the quadratic polynomials
  9111. ${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and
  9112. ${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$.
  9113. Since we may be calculating slopes from several cubics
  9114. split from the current one, it is desirable to do these calculations
  9115. without losing too much precision. ``Scaled up'' values of the
  9116. derivatives, which will be less tainted by accumulated errors than
  9117. derivatives found from the cubics themselves, are maintained in
  9118. local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$,
  9119. $X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2|
  9120. represent $Y_0=2^l(y_1-y_0)$, $Y_1=2^l(y_2-y_1)$, and $Y_2=2^l(y_3-y_2)$.
  9121. To test whether the slope of the cubic is $\ge s$ or $\le s$, we will test
  9122. the sign of the quadratic ${1\over3}2^l\bigl(y'(t)-sx'(t)\bigr)$ if $s\le1$,
  9123. or ${1\over3}2^l\bigl(y'(t)/s-x'(t)\bigr)$ if $s>1$.
  9124. @<Other local variables for |offset_prep|@>=
  9125. @!x0,@!x1,@!x2,@!y0,@!y1,@!y2:integer; {representatives of derivatives}
  9126. @!t0,@!t1,@!t2:integer; {coefficients of polynomial for slope testing}
  9127. @!du,@!dv,@!dx,@!dy:integer; {for slopes of the pen and the curve}
  9128. @!max_coef:integer; {used while scaling}
  9129. @!x0a,@!x1a,@!x2a,@!y0a,@!y1a,@!y2a:integer; {intermediate values}
  9130. @!t:fraction; {where the derivative passes through zero}
  9131. @!s:fraction; {slope or reciprocal slope}
  9132. @ @<Prepare for derivative computations...@>=
  9133. x0:=right_x(p)-x_coord(p); {should be |>=0|}
  9134. x2:=x_coord(q)-left_x(q); {likewise}
  9135. x1:=left_x(q)-right_x(p); {but this might be negative}
  9136. y0:=right_y(p)-y_coord(p); y2:=y_coord(q)-left_y(q);
  9137. y1:=left_y(q)-right_y(p);
  9138. max_coef:=abs(x0); {we take |abs| just to make sure}
  9139. if abs(x1)>max_coef then max_coef:=abs(x1);
  9140. if abs(x2)>max_coef then max_coef:=abs(x2);
  9141. if abs(y0)>max_coef then max_coef:=abs(y0);
  9142. if abs(y1)>max_coef then max_coef:=abs(y1);
  9143. if abs(y2)>max_coef then max_coef:=abs(y2);
  9144. if max_coef=0 then goto not_found;
  9145. while max_coef<fraction_half do
  9146.   begin double(max_coef);
  9147.   double(x0); double(x1); double(x2);
  9148.   double(y0); double(y1); double(y2);
  9149.   end
  9150. @ Let us first solve a special case of the problem: Suppose we
  9151. know an index~$k$ such that either (i)~$s(t)\G s_{k-1}$ for all~$t$
  9152. and $s(0)<s_k$, or (ii)~$s(t)\L s_k$ for all~$t$ and $s(0)>s_{k-1}$.
  9153. Then, in a sense, we're halfway done, since one of the two inequalities
  9154. in $(*)$ is satisfied, and the other couldn't be satisfied for
  9155. any other value of~|k|.
  9156. The |fin_offset_prep| subroutine solves the stated subproblem.
  9157. It has a boolean parameter called |rising| that is |true| in
  9158. case~(i), |false| in case~(ii). When |rising=false|, parameters
  9159. |x0| through |y2| represent the negative of the derivative of
  9160. the cubic following |p|; otherwise they represent the actual derivative.
  9161. The |w| parameter should point to offset~$w_k$.
  9162. @<Declare subroutines needed by |offset_prep|@>=
  9163. procedure fin_offset_prep(@!p:pointer;@!k:halfword;@!w:pointer;
  9164.   @!x0,@!x1,@!x2,@!y0,@!y1,@!y2:integer;@!rising:boolean;@!n:integer);
  9165. label exit;
  9166. var @!ww:pointer; {for list manipulation}
  9167. @!du,@!dv:scaled; {for slope calculation}
  9168. @!t0,@!t1,@!t2:integer; {test coefficients}
  9169. @!t:fraction; {place where the derivative passes a critical slope}
  9170. @!s:fraction; {slope or reciprocal slope}
  9171. @!v:integer; {intermediate value for updating |x0..y2|}
  9172. begin loop
  9173.   begin right_type(p):=k;
  9174.   if rising then
  9175.     if k=n then return
  9176.     else ww:=link(w) {a pointer to $w\k$}
  9177.   else  if k=1 then return
  9178.     else ww:=knil(w); {a pointer to $w_{k-1}$}
  9179.   @<Compute test coefficients |(t0,t1,t2)|
  9180.     for $s(t)$ versus $s_k$ or $s_{k-1}$@>;
  9181.   t:=crossing_point(t0,t1,t2);
  9182.   if t>=fraction_one then return;
  9183.   @<Split the cubic at $t$,
  9184.     and split off another cubic if the derivative crosses back@>;
  9185.   if rising then incr(k)@+else decr(k);
  9186.   w:=ww;
  9187.   end;
  9188. exit:end;
  9189. @ @<Compute test coefficients |(t0,t1,t2)| for $s(t)$ versus...@>=
  9190. du:=x_coord(ww)-x_coord(w); dv:=y_coord(ww)-y_coord(w);
  9191. if abs(du)>=abs(dv) then {$s_{k\pm1}\le1$}
  9192.   begin s:=make_fraction(dv,du);
  9193.   t0:=take_fraction(x0,s)-y0;
  9194.   t1:=take_fraction(x1,s)-y1;
  9195.   t2:=take_fraction(x2,s)-y2;
  9196.   end
  9197. else  begin s:=make_fraction(du,dv);
  9198.   t0:=x0-take_fraction(y0,s);
  9199.   t1:=x1-take_fraction(y1,s);
  9200.   t2:=x2-take_fraction(y2,s);
  9201.   end
  9202. @ The curve has crossed $s_k$ or $s_{k-1}$; its initial segment satisfies
  9203. $(*)$, and it might cross again and return towards $s_k$, yielding another
  9204. solution of $(*)$.
  9205. @<Split the cubic at $t$, and split off another...@>=
  9206. begin split_for_offset(p,t); right_type(p):=k; p:=link(p);@/
  9207. v:=t_of_the_way(x0)(x1); x1:=t_of_the_way(x1)(x2);
  9208. x0:=t_of_the_way(v)(x1);@/
  9209. v:=t_of_the_way(y0)(y1); y1:=t_of_the_way(y1)(y2);
  9210. y0:=t_of_the_way(v)(y1);@/
  9211. t1:=t_of_the_way(t1)(t2);
  9212. if t1>0 then t1:=0; {without rounding error, |t1| would be |<=0|}
  9213. t:=crossing_point(0,-t1,-t2);
  9214. if t<fraction_one then
  9215.   begin split_for_offset(p,t); right_type(link(p)):=k;@/
  9216.   v:=t_of_the_way(x1)(x2); x1:=t_of_the_way(x0)(x1);
  9217.   x2:=t_of_the_way(x1)(v);@/
  9218.   v:=t_of_the_way(y1)(y2); y1:=t_of_the_way(y0)(y1);
  9219.   y2:=t_of_the_way(y1)(v);
  9220.   end;
  9221. @ Now we must consider the general problem of |offset_prep|, when
  9222. nothing is known about a given cubic. We start by finding its
  9223. slope $s(0)$ in the vicinity of |t=0|.
  9224. If $z'(t)=0$, the given cubic is numerically unstable, since the
  9225. slope direction is probably being influenced primarily by rounding
  9226. errors. A user who specifies such cuspy curves should expect to generate
  9227. rather wild results. The present code tries its best to believe the
  9228. existing data, as if no rounding errors were present.
  9229. @ @<Find the initial slope, |dy/dx|@>=
  9230. dx:=x0; dy:=y0;
  9231. if dx=0 then if dy=0 then
  9232.   begin dx:=x1; dy:=y1;
  9233.   if dx=0 then if dy=0 then
  9234.     begin dx:=x2; dy:=y2;
  9235.     end;
  9236.   end
  9237. @ The next step is to bracket the initial slope between consecutive
  9238. slopes of the pen polygon. The most important invariant relation in the
  9239. following loop is that |dy/dx>=@t$s_{k-1}$@>|.
  9240. @<Find the index |k| such that $s_{k-1}\L\\{dy}/\\{dx}<s_k$@>=
  9241. k:=1; w:=link(lh);
  9242. loop@+  begin if k=n then goto done;
  9243.   ww:=link(w);
  9244.   if ab_vs_cd(dy,abs(x_coord(ww)-x_coord(w)),@|
  9245.    dx,abs(y_coord(ww)-y_coord(w)))>=0 then
  9246.     begin incr(k); w:=ww;
  9247.     end
  9248.   else goto done;
  9249.   end;
  9250. done:
  9251. @ Finally we want to reduce the general problem to situations that
  9252. |fin_offset_prep| can handle. If |k=1|, we already are in the desired
  9253. situation. Otherwise we can split the cubic into at most three parts
  9254. with respect to $s_{k-1}$, and apply |fin_offset_prep| to each part.
  9255. @<Complete the offset splitting process@>=
  9256. if k=1 then t:=fraction_one+1
  9257. else  begin ww:=knil(w); @<Compute test coeff...@>;
  9258.   t:=crossing_point(-t0,-t1,-t2);
  9259.   end;
  9260. if t>=fraction_one then fin_offset_prep(p,k,w,x0,x1,x2,y0,y1,y2,true,n)
  9261. else  begin split_for_offset(p,t); r:=link(p);@/
  9262.   x1a:=t_of_the_way(x0)(x1); x1:=t_of_the_way(x1)(x2);
  9263.   x2a:=t_of_the_way(x1a)(x1);@/
  9264.   y1a:=t_of_the_way(y0)(y1); y1:=t_of_the_way(y1)(y2);
  9265.   y2a:=t_of_the_way(y1a)(y1);@/
  9266.   fin_offset_prep(p,k,w,x0,x1a,x2a,y0,y1a,y2a,true,n); x0:=x2a; y0:=y2a;
  9267.   t1:=t_of_the_way(t1)(t2);
  9268.   if t1<0 then t1:=0;
  9269.   t:=crossing_point(0,t1,t2);
  9270.   if t<fraction_one then
  9271.     @<Split off another |rising| cubic for |fin_offset_prep|@>;
  9272.   fin_offset_prep(r,k-1,ww,-x0,-x1,-x2,-y0,-y1,-y2,false,n);
  9273.   end
  9274. @ @<Split off another |rising| cubic for |fin_offset_prep|@>=
  9275. begin split_for_offset(r,t);@/
  9276. x1a:=t_of_the_way(x1)(x2); x1:=t_of_the_way(x0)(x1);
  9277. x0a:=t_of_the_way(x1)(x1a);@/
  9278. y1a:=t_of_the_way(y1)(y2); y1:=t_of_the_way(y0)(y1);
  9279. y0a:=t_of_the_way(y1)(y1a);@/
  9280. fin_offset_prep(link(r),k,w,x0a,x1a,x2,y0a,y1a,y2,true,n);
  9281. x2:=x0a; y2:=y0a;
  9282. @ @<Handle the special case of infinite slope@>=
  9283. fin_offset_prep(p,n,knil(knil(lh)),-x0,-x1,-x2,-y0,-y1,-y2,false,n)
  9284. @ OK, it's time now for the biggie. The |fill_envelope| routine generalizes
  9285. |fill_spec| to polygonal envelopes. Its outer structure is essentially the
  9286. same as before, except that octants with no cubics do contribute to
  9287. the envelope.
  9288. @p @t\4@>@<Declare the procedure called |skew_line_edges|@>@;
  9289. @t\4@>@<Declare the procedure called |dual_moves|@>@;
  9290. procedure fill_envelope(@!spec_head:pointer);
  9291. label done, done1;
  9292. var @!p,@!q,@!r,@!s:pointer; {for list traversal}
  9293. @!h:pointer; {head of pen offset list for current octant}
  9294. @!www:pointer; {a pen offset of temporary interest}
  9295. @<Other local variables for |fill_envelope|@>@;
  9296. begin if internal[tracing_edges]>0 then begin_edge_tracing;
  9297. p:=spec_head; {we assume that |left_type(spec_head)=endpoint|}
  9298. repeat octant:=left_octant(p); h:=cur_pen+octant;
  9299. @<Set variable |q| to the node at the end of the current octant@>;
  9300. @<Determine the envelope's starting and ending
  9301.     lattice points |(m0,n0)| and |(m1,n1)|@>;
  9302. offset_prep(p,h); {this may clobber node~|q|, if it becomes ``dead''}
  9303. @<Set variable |q| to the node at the end of the current octant@>;
  9304. @<Make the envelope moves for the current octant and insert them
  9305.   in the pixel data@>;
  9306. p:=link(q);
  9307. until p=spec_head;
  9308. if internal[tracing_edges]>0 then end_edge_tracing;
  9309. toss_knot_list(spec_head);
  9310. @ In even-numbered octants we have reflected the coordinates an odd number
  9311. of times, hence clockwise and counterclockwise are reversed; this means that
  9312. the envelope is being formed in a ``dual'' manner. For the time being, let's
  9313. concentrate on odd-numbered octants, since they're easier to understand.
  9314. After we have coded the program for odd-numbered octants, the changes needed
  9315. to dualize it will not be so mysterious.
  9316. It is convenient to assume that we enter an odd-numbered octant with
  9317. an |axis| transition (where the skewed slope is zero) and leave at a
  9318. |diagonal| one (where the skewed slope is infinite). Then all of the
  9319. offset points $z(t)+w(t)$ will lie in a rectangle whose lower left and
  9320. upper right corners are the initial and final offset points. If this
  9321. assumption doesn't hold we can implicitly change the curve so that it does.
  9322. For example, if the entering transition is diagonal, we can draw a
  9323. straight line from $z_0+w_{n+1}$ to $z_0+w_0$ and continue as if the
  9324. curve were moving rightward. The effect of this on the envelope is simply
  9325. to ``doubly color'' the region enveloped by a section of the pen that
  9326. goes from $w_0$ to $w_1$ to $\cdots$ to $w_{n+1}$ to~$w_0$. The additional
  9327. straight line at the beginning (and a similar one at the end, where it
  9328. may be necessary to go from $z_1+w_{n+1}$ to $z_1+w_0$) can be drawn by
  9329. the |line_edges| routine; we are thereby saved from the embarrassment that
  9330. these lines travel backwards from the current octant direction.
  9331. Once we have established the assumption that the curve goes from
  9332. $z_0+w_0$ to $z_1+w_{n+1}$, any further retrograde moves that might
  9333. occur within the octant can be essentially ignored; we merely need to
  9334. keep track of the rightmost edge in each row, in order to compute
  9335. the envelope.
  9336. Envelope moves consist of offset cubics intermixed with straight line
  9337. segments. We record them in a separate |env_move| array, which is
  9338. something like |move| but it keeps track of the rightmost position of the
  9339. envelope in each row.
  9340. @<Glob...@>=
  9341. @!env_move:array[0..move_size] of integer;
  9342. @ @<Determine the envelope's starting and ending...@>=
  9343. w:=link(h);@+if left_transition(p)=diagonal then w:=knil(w);
  9344. @!stat if internal[tracing_edges]>unity then
  9345.   @<Print a line of diagnostic info to introduce this octant@>;
  9346. tats@;@/
  9347. ww:=link(h); www:=ww; {starting and ending offsets}
  9348. if odd(octant_number[octant]) then www:=knil(www)@+else ww:=knil(ww);
  9349. if w<>ww then skew_line_edges(p,w,ww);
  9350. end_round(x_coord(p)+x_coord(ww),y_coord(p)+y_coord(ww));
  9351. m0:=m1; n0:=n1; d0:=d1;@/
  9352. end_round(x_coord(q)+x_coord(www),y_coord(q)+y_coord(www));
  9353. if n1-n0>=move_size then overflow("move table size",move_size)
  9354. @:METAFONT capacity exceeded move table size}{\quad move table size@>
  9355. @ @<Print a line of diagnostic info to introduce this octant@>=
  9356. begin print_nl("@@ Octant "); print(octant_dir[octant]);
  9357. @:]]]\AT!_Octant}{\.{\AT! Octant...}@>
  9358. print(" ("); print_int(info(h)); print(" offset");
  9359. if info(h)<>1 then print_char("s");
  9360. print("), from ");
  9361. print_two_true(x_coord(p)+x_coord(w),y_coord(p)+y_coord(w));
  9362. ww:=link(h);@+if right_transition(q)=diagonal then ww:=knil(ww);
  9363. print(" to ");
  9364. print_two_true(x_coord(q)+x_coord(ww),y_coord(q)+y_coord(ww));
  9365. @ A slight variation of the |line_edges| procedure comes in handy
  9366. when we must draw the retrograde lines for nonstandard entry and exit
  9367. conditions.
  9368. @<Declare the procedure called |skew_line_edges|@>=
  9369. procedure skew_line_edges(@!p,@!w,@!ww:pointer);
  9370. var @!x0,@!y0,@!x1,@!y1:scaled; {from and to}
  9371. begin if (x_coord(w)<>x_coord(ww))or(y_coord(w)<>y_coord(ww)) then
  9372.   begin x0:=x_coord(p)+x_coord(w); y0:=y_coord(p)+y_coord(w);@/
  9373.   x1:=x_coord(p)+x_coord(ww); y1:=y_coord(p)+y_coord(ww);@/
  9374.   unskew(x0,y0,octant); {unskew and unrotate the coordinates}
  9375.   x0:=cur_x; y0:=cur_y;@/
  9376.   unskew(x1,y1,octant);@/
  9377.   @!stat if internal[tracing_edges]>unity then
  9378.     begin print_nl("@@ retrograde line from ");
  9379. @:]]]\AT!_retro_}{\.{\AT! retrograde line...}@>
  9380.   @.retrograde line...@>
  9381.     print_two(x0,y0); print(" to "); print_two(cur_x,cur_y); print_nl("");
  9382.     end;@+tats@;@/
  9383.   line_edges(x0,y0,cur_x,cur_y); {then draw a straight line}
  9384.   end;
  9385. @ The envelope calculations require more local variables than we needed
  9386. in the simpler case of |fill_spec|. At critical points in the computation,
  9387. |w| will point to offset $w_k$; |m| and |n| will record the current
  9388. lattice positions.  The values of |move_ptr| after the initial and before
  9389. the final offset adjustments are stored in |smooth_bot| and |smooth_top|,
  9390. respectively.
  9391. @<Other local variables for |fill_envelope|@>=
  9392. @!m,@!n:integer; {current lattice position}
  9393. @!mm0,@!mm1:integer; {skewed equivalents of |m0| and |m1|}
  9394. @!k:integer; {current offset number}
  9395. @!w,@!ww:pointer; {pointers to the current offset and its neighbor}
  9396. @!smooth_bot,@!smooth_top:0..move_size; {boundaries of smoothing}
  9397. @!xx,@!yy,@!xp,@!yp,@!delx,@!dely,@!tx,@!ty:scaled;
  9398.   {registers for coordinate calculations}
  9399. @ @<Make the envelope moves for the current octant...@>=
  9400. if odd(octant_number[octant]) then
  9401.   begin @<Initialize for ordinary envelope moves@>;
  9402.   r:=p; right_type(q):=info(h)+1;
  9403.   loop@+  begin if r=q then smooth_top:=move_ptr;
  9404.     while right_type(r)<>k do
  9405.       @<Insert a line segment to approach the correct offset@>;
  9406.     if r=p then smooth_bot:=move_ptr;
  9407.     if r=q then goto done;
  9408.     move[move_ptr]:=1; n:=move_ptr; s:=link(r);@/
  9409.     make_moves(x_coord(r)+x_coord(w),right_x(r)+x_coord(w),
  9410.       left_x(s)+x_coord(w),x_coord(s)+x_coord(w),@|
  9411.       y_coord(r)+y_coord(w)+half_unit,right_y(r)+y_coord(w)+half_unit,
  9412.       left_y(s)+y_coord(w)+half_unit,y_coord(s)+y_coord(w)+half_unit,@|
  9413.       xy_corr[octant],y_corr[octant]);@/
  9414.     @<Transfer moves from the |move| array to |env_move|@>;
  9415.     r:=s;
  9416.     end;
  9417. done:  @<Insert the new envelope moves in the pixel data@>;
  9418.   end
  9419. else dual_moves(h,p,q);
  9420. right_type(q):=endpoint
  9421. @ @<Initialize for ordinary envelope moves@>=
  9422. k:=0; w:=link(h); ww:=knil(w);
  9423. mm0:=floor_unscaled(x_coord(p)+x_coord(w)-xy_corr[octant]);
  9424. mm1:=floor_unscaled(x_coord(q)+x_coord(ww)-xy_corr[octant]);
  9425. for n:=0 to n1-n0 do env_move[n]:=mm0;
  9426. env_move[n1-n0]:=mm1; move_ptr:=0; m:=mm0
  9427. @ At this point |n| holds the value of |move_ptr| that was current
  9428. when |make_moves| began to record its moves.
  9429. @<Transfer moves from the |move| array to |env_move|@>=
  9430. repeat m:=m+move[n]-1;
  9431. if m>env_move[n] then env_move[n]:=m;
  9432. incr(n);
  9433. until n>move_ptr
  9434. @ Retrograde lines (when |k| decreases) do not need to be recorded in
  9435. |env_move| because their edges are not the furthest right in any row.
  9436. @<Insert a line segment to approach the correct offset@>=
  9437. begin xx:=x_coord(r)+x_coord(w); yy:=y_coord(r)+y_coord(w)+half_unit;
  9438. @!stat if internal[tracing_edges]>unity then
  9439.   begin print_nl("@@ transition line "); print_int(k); print(", from ");
  9440. @:]]]\AT!_trans_}{\.{\AT! transition line...}@>
  9441. @.transition line...@>
  9442.   print_two_true(xx,yy-half_unit);
  9443.   end;@+tats@;@/
  9444. if right_type(r)>k then
  9445.   begin incr(k); w:=link(w);
  9446.   xp:=x_coord(r)+x_coord(w); yp:=y_coord(r)+y_coord(w)+half_unit;
  9447.   if yp<>yy then
  9448.     @<Record a line segment from |(xx,yy)| to |(xp,yp)| in |env_move|@>;
  9449.   end
  9450. else  begin decr(k); w:=knil(w);
  9451.   xp:=x_coord(r)+x_coord(w); yp:=y_coord(r)+y_coord(w)+half_unit;
  9452.   end;
  9453. stat if internal[tracing_edges]>unity then
  9454.   begin print(" to ");
  9455.   print_two_true(xp,yp-half_unit);
  9456.   print_nl("");
  9457.   end;@+tats@;@/
  9458. m:=floor_unscaled(xp-xy_corr[octant]);
  9459. move_ptr:=floor_unscaled(yp-y_corr[octant])-n0;
  9460. if m>env_move[move_ptr] then env_move[move_ptr]:=m;
  9461. @ In this step we have |xp>=xx| and |yp>=yy|.
  9462. @<Record a line segment from |(xx,yy)| to |(xp,yp)| in |env_move|@>=
  9463. begin ty:=floor_scaled(yy-y_corr[octant]); dely:=yp-yy; yy:=yy-ty;
  9464. ty:=yp-y_corr[octant]-ty;
  9465. if ty>=unity then
  9466.   begin delx:=xp-xx; yy:=unity-yy;
  9467.   loop@+  begin tx:=take_fraction(delx,make_fraction(yy,dely));
  9468.     if ab_vs_cd(tx,dely,delx,yy)+xy_corr[octant]>0 then decr(tx);
  9469.     m:=floor_unscaled(xx+tx);
  9470.     if m>env_move[move_ptr] then env_move[move_ptr]:=m;
  9471.     ty:=ty-unity;
  9472.     if ty<unity then goto done1;
  9473.     yy:=yy+unity; incr(move_ptr);
  9474.     end;
  9475.   done1:end;
  9476. @ @<Insert the new envelope moves in the pixel data@>=
  9477. debug if (m<>mm1)or(move_ptr<>n1-n0) then confusion("1");@+gubed@;@/
  9478. move[0]:=d0+env_move[0]-mm0;
  9479. for n:=1 to move_ptr do
  9480.   move[n]:=env_move[n]-env_move[n-1]+1;
  9481. move[move_ptr]:=move[move_ptr]-d1;
  9482. if internal[smoothing]>0 then smooth_moves(smooth_bot,smooth_top);
  9483. move_to_edges(m0,n0,m1,n1);
  9484. if right_transition(q)=axis then
  9485.   begin w:=link(h); skew_line_edges(q,knil(w),w);
  9486.   end
  9487. @ We've done it all in the odd-octant case; the only thing remaining
  9488. is to repeat the same ideas, upside down and/or backwards.
  9489. The following code has been split off as a subprocedure of |fill_envelope|,
  9490. because some \PASCAL\ compilers cannot handle procedures as large as
  9491. |fill_envelope| would otherwise be.
  9492. @<Declare the procedure called |dual_moves|@>=
  9493. procedure dual_moves(@!h,@!p,@!q:pointer);
  9494. label done,done1;
  9495. var @!r,@!s:pointer; {for list traversal}
  9496. @<Other local variables for |fill_envelope|@>@;
  9497. begin @<Initialize for dual envelope moves@>;
  9498. r:=p; {recall that |right_type(q)=endpoint=0| now}
  9499. loop@+  begin if r=q then smooth_top:=move_ptr;
  9500.   while right_type(r)<>k do
  9501.     @<Insert a line segment dually to approach the correct offset@>;
  9502.   if r=p then smooth_bot:=move_ptr;
  9503.   if r=q then goto done;
  9504.   move[move_ptr]:=1; n:=move_ptr; s:=link(r);@/
  9505.   make_moves(x_coord(r)+x_coord(w),right_x(r)+x_coord(w),
  9506.     left_x(s)+x_coord(w),x_coord(s)+x_coord(w),@|
  9507.     y_coord(r)+y_coord(w)+half_unit,right_y(r)+y_coord(w)+half_unit,
  9508.     left_y(s)+y_coord(w)+half_unit,y_coord(s)+y_coord(w)+half_unit,@|
  9509.     xy_corr[octant],y_corr[octant]);
  9510.   @<Transfer moves dually from the |move| array to |env_move|@>;
  9511.   r:=s;
  9512.   end;
  9513. done:@<Insert the new envelope moves dually in the pixel data@>;
  9514. @ In the dual case the normal situation is to arrive with a |diagonal|
  9515. transition and to leave at the |axis|. The leftmost edge in each row
  9516. is relevant instead of the rightmost one.
  9517. @<Initialize for dual envelope moves@>=
  9518. k:=info(h)+1; ww:=link(h); w:=knil(ww);@/
  9519. mm0:=floor_unscaled(x_coord(p)+x_coord(w)-xy_corr[octant]);
  9520. mm1:=floor_unscaled(x_coord(q)+x_coord(ww)-xy_corr[octant]);
  9521. for n:=1 to n1-n0+1 do env_move[n]:=mm1;
  9522. env_move[0]:=mm0; move_ptr:=0; m:=mm0
  9523. @ @<Transfer moves dually from the |move| array to |env_move|@>=
  9524. repeat if m<env_move[n] then env_move[n]:=m;
  9525. m:=m+move[n]-1;
  9526. incr(n);
  9527. until n>move_ptr
  9528. @ Dual retrograde lines occur when |k| increases; the edges of such lines
  9529. are not the furthest left in any row.
  9530. @<Insert a line segment dually to approach the correct offset@>=
  9531. begin xx:=x_coord(r)+x_coord(w); yy:=y_coord(r)+y_coord(w)+half_unit;
  9532. @!stat if internal[tracing_edges]>unity then
  9533.   begin print_nl("@@ transition line "); print_int(k); print(", from ");
  9534. @:]]]\AT!_trans_}{\.{\AT! transition line...}@>
  9535. @.transition line...@>
  9536.   print_two_true(xx,yy-half_unit);
  9537.   end;@+tats@;@/
  9538. if right_type(r)<k then
  9539.   begin decr(k); w:=knil(w);
  9540.   xp:=x_coord(r)+x_coord(w); yp:=y_coord(r)+y_coord(w)+half_unit;
  9541.   if yp<>yy then
  9542.     @<Record a line segment from |(xx,yy)| to |(xp,yp)| dually in |env_move|@>;
  9543.   end
  9544. else  begin incr(k); w:=link(w);
  9545.   xp:=x_coord(r)+x_coord(w); yp:=y_coord(r)+y_coord(w)+half_unit;
  9546.   end;
  9547. stat if internal[tracing_edges]>unity then
  9548.   begin print(" to ");
  9549.   print_two_true(xp,yp-half_unit);
  9550.   print_nl("");
  9551.   end;@+tats@;@/
  9552. m:=floor_unscaled(xp-xy_corr[octant]);
  9553. move_ptr:=floor_unscaled(yp-y_corr[octant])-n0;
  9554. if m<env_move[move_ptr] then env_move[move_ptr]:=m;
  9555. @ Again, |xp>=xx| and |yp>=yy|; but this time we are interested in the {\sl
  9556. smallest\/} |m| that belongs to a given |move_ptr| position, instead of
  9557. the largest~|m|.
  9558. @<Record a line segment from |(xx,yy)| to |(xp,yp)| dually in |env_move|@>=
  9559. begin ty:=floor_scaled(yy-y_corr[octant]); dely:=yp-yy; yy:=yy-ty;
  9560. ty:=yp-y_corr[octant]-ty;
  9561. if ty>=unity then
  9562.   begin delx:=xp-xx; yy:=unity-yy;
  9563.   loop@+  begin if m<env_move[move_ptr] then env_move[move_ptr]:=m;
  9564.     tx:=take_fraction(delx,make_fraction(yy,dely));
  9565.     if ab_vs_cd(tx,dely,delx,yy)+xy_corr[octant]>0 then decr(tx);
  9566.     m:=floor_unscaled(xx+tx);
  9567.     ty:=ty-unity; incr(move_ptr);
  9568.     if ty<unity then goto done1;
  9569.     yy:=yy+unity;
  9570.     end;
  9571. done1:  if m<env_move[move_ptr] then env_move[move_ptr]:=m;
  9572.   end;
  9573. @ Since |env_move| contains minimum values instead of maximum values, the
  9574. finishing-up process is slightly different in the dual case.
  9575. @<Insert the new envelope moves dually in the pixel data@>=
  9576. debug if (m<>mm1)or(move_ptr<>n1-n0) then confusion("2");@+gubed@;@/
  9577. move[0]:=d0+env_move[1]-mm0;
  9578. for n:=1 to move_ptr do
  9579.   move[n]:=env_move[n+1]-env_move[n]+1;
  9580. move[move_ptr]:=move[move_ptr]-d1;
  9581. if internal[smoothing]>0 then smooth_moves(smooth_bot,smooth_top);
  9582. move_to_edges(m0,n0,m1,n1);
  9583. if right_transition(q)=diagonal then
  9584.   begin w:=link(h); skew_line_edges(q,w,knil(w));
  9585.   end
  9586. @* \[25] Elliptical pens.
  9587. To get the envelope of a cyclic path with respect to an ellipse, \MF\
  9588. calculates the envelope with respect to a polygonal approximation to
  9589. the ellipse, using an approach due to John Hobby (Ph.D. thesis,
  9590. Stanford University, 1985).
  9591. @^Hobby, John Douglas@>
  9592. This has two important advantages over trying to obtain the ``exact''
  9593. envelope:
  9594. \yskip\textindent{1)}It gives better results, because the polygon has been
  9595. designed to counteract problems that arise from digitization; the
  9596. polygon includes sub-pixel corrections to an exact ellipse that make
  9597. the results essentially independent of where the path falls on the raster.
  9598. For example, the exact envelope with respect to a pen of diameter~1
  9599. blackens a pixel if and only if the path intersects a circle of diameter~1
  9600. inscribed in that pixel; the resulting pattern has ``blots'' when the path
  9601. is travelling diagonally in unfortunate raster positions. A much better
  9602. result is obtained when pixels are blackened only when the path intersects
  9603. an inscribed {\sl diamond\/} of diameter~1. Such a diamond is precisely
  9604. the polygon that \MF\ uses in the special case of a circle whose diameter is~1.
  9605. \yskip\textindent{2)}Polygonal envelopes of cubic splines are cubic
  9606. splines, hence it isn't necessary to introduce completely different
  9607. routines. By contrast, exact envelopes of cubic splines with respect
  9608. to circles are complicated curves, more difficult to plot than cubics.
  9609. @ Hobby's construction involves some interesting number theory.
  9610. If $u$ and~$v$ are relatively prime integers, we divide the
  9611. set of integer points $(m,n)$ into equivalence classes by saying
  9612. that $(m,n)$ belongs to class $um+vn$. Then any two integer points
  9613. that lie on a line of slope $-u/v$ belong to the same class, because
  9614. such points have the form $(m+tv,n-tu)$. Neighboring lines of slope $-u/v$
  9615. that go through integer points are separated by distance $1/\psqrt{u^2+v^2}$
  9616. from each other, and these lines are perpendicular to lines of slope~$v/u$.
  9617. If we start at the origin and travel a distance $k/\psqrt{u^2+v^2}$ in
  9618. direction $(u,v)$, we reach the line of slope~$-u/v$ whose points
  9619. belong to class~$k$.
  9620. For example, let $u=2$ and $v=3$. Then the points $(0,0)$, $(3,-2)$,
  9621. $\ldots$ belong to class~0; the points $(-1,1)$, $(2,-1)$, $\ldots$ belong
  9622. to class~1; and the distance between these two lines is $1/\sqrt{13}$.
  9623. The point $(2,3)$ itself belongs to class~13, hence its distance from
  9624. the origin is $13/\sqrt{13}=\sqrt{13}$ (which we already knew).
  9625. Suppose we wish to plot envelopes with respect to polygons with
  9626. integer vertices. Then the best polygon for curves that travel in
  9627. direction $(v,-u)$ will contain the points of class~$k$ such that
  9628. $k/\psqrt{u^2+v^2}$ is as close as possible to~$d$, where $d$ is the
  9629. maximum distance of the given ellipse from the line $ux+vy=0$.
  9630. The |fillin| correction assumes that a diagonal line has an
  9631. apparent thickness $$2f\cdot\min(\vert u\vert,\vert v\vert)/\psqrt{u^2+v^2}$$
  9632. greater than would be obtained with truly square pixels. (If a
  9633. white pixel at an exterior corner is assumed to have apparent
  9634. darkness $f_1$ and a black pixel at an interior corner is assumed
  9635. to have apparent darkness $1-f_2$, then $f=f_1-f_2$ is the |fillin|
  9636. parameter.) Under this assumption we want to choose $k$ so that
  9637. $\bigl(k+2f\cdot\min(\vert u\vert,\vert v\vert)\bigr)\big/\psqrt{u^2+v^2}$
  9638. is as close as possible to $d$.
  9639. Integer coordinates for the vertices work nicely because the thickness of
  9640. the envelope at any given slope is independent of the position of the
  9641. path with respect to the raster. It turns out, in fact, that the same
  9642. property holds for polygons whose vertices have coordinates that are
  9643. integer multiples of~$1\over2$, because ellipses are symmetric about
  9644. the origin. It's convenient to double all dimensions and require the
  9645. resulting polygon to have vertices with integer coordinates. For example,
  9646. to get a circle of {\sl diameter}~$r$, we shall compute integer
  9647. coordinates for a circle of {\sl radius}~$r$. The circle of radius~$r$
  9648. will want to be represented by a polygon that contains the boundary
  9649. points $(0,\pm r)$ and~$(\pm r,0)$; later we will divide everything
  9650. by~2 and get a polygon with $(0,\pm{1\over2}r)$ and $(\pm{1\over2}r,0)$
  9651. on its boundary.
  9652. @ In practice the important slopes are those having small values of
  9653. $u$ and~$v$; these make regular patterns in which our eyes quickly
  9654. spot irregularities. For example, horizontal and vertical lines
  9655. (when $u=0$ and $\vert v\vert=1$, or $\vert u\vert=1$ and $v=0$)
  9656. are the most important; diagonal lines (when $\vert u\vert=\vert v\vert=1$)
  9657. are next; and then come lines with slope $\pm2$ or $\pm1/2$.
  9658. The nicest way to generate all rational directions having small
  9659. numerators and denominators is to generalize the Stern-Brocot tree
  9660. [cf.~{\sl Concrete Mathematics}, section 4.5]
  9661. @^Brocot, Achille@>
  9662. @^Stern, Moriz Abraham@>
  9663. to a ``Stern-Brocot wreath'' as follows: Begin with four nodes
  9664. arranged in a circle, containing the respective directions
  9665. $(u,v)=(1,0)$, $(0,1)$, $(-1,0)$, and~$(0,-1)$. Then between pairs of
  9666. consecutive terms $(u,v)$ and $(u',v')$ of the wreath, insert the
  9667. direction $(u+u',v+v')$; continue doing this until some stopping
  9668. criterion is fulfilled.
  9669. It is not difficult to verify that, regardless of the stopping
  9670. criterion, consecutive directions $(u,v)$ and $(u',v')$ of this
  9671. wreath will always satisfy the relation $uv'-u'v=1$. Such pairs
  9672. of directions have a nice property with respect to the equivalence
  9673. classes described above. Let $l$ be a line of equivalent integer points
  9674. $(m+tv,n-tu)$ with respect to~$(u,v)$, and let $l'$ be a line of
  9675. equivalent integer points $(m'+tv',n'-tu')$ with respect to~$(u',v')$.
  9676. Then $l$ and~$l'$ intersect in an integer point $(m'',n'')$, because
  9677. the determinant of the linear equations for intersection is $uv'-u'v=1$.
  9678. Notice that the class number of $(m'',n'')$ with respect to $(u+u',v+v')$
  9679. is the sum of its class numbers with respect to $(u,v)$ and~$(u',v')$.
  9680. Moreover, consecutive points on~$l$ and~$l'$ belong to classes that
  9681. differ by exactly~1 with respect to $(u+u',v+v')$.
  9682. This leads to a nice algorithm in which we construct a polygon having
  9683. ``correct'' class numbers for as many small-integer directions $(u,v)$
  9684. as possible: Assuming that lines $l$ and~$l'$ contain points of the
  9685. correct class for $(u,v)$ and~$(u',v')$, respectively, we determine
  9686. the intersection $(m'',n'')$ and compute its class with respect to
  9687. $(u+u',v+v')$. If the class is too large to be the best approximation,
  9688. we move back the proper number of steps from $(m'',n'')$ toward smaller
  9689. class numbers on both $l$ and~$l'$, unless this requires moving to points
  9690. that are no longer in the polygon; in this we arrive at two points that
  9691. determine a line~$l''$ having the appropriate class. The process continues
  9692. recursively, until it cannot proceed without removing the last remaining
  9693. point from the class for $(u,v)$ or the class for $(u',v')$.
  9694. @ The |make_ellipse| subroutine produces a pointer to a cyclic path
  9695. whose vertices define a polygon suitable for envelopes. The control
  9696. points on this path will be ignored; in fact, the fields in knot nodes
  9697. that are usually reserved for control points are occupied by other
  9698. data that helps |make_ellipse| compute the desired polygon.
  9699. Parameters |major_axis| and |minor_axis| define the axes of the ellipse;
  9700. and parameter |theta| is an angle by which the ellipse is rotated
  9701. counterclockwise. If |theta=0|, the ellipse has the equation
  9702. $(x/a)^2+(y/b)^2=1$, where |a=major_axis/2| and |b=minor_axis/2|.
  9703. In general, the points of the ellipse are generated in the complex plane
  9704. by the formula $e^{i\theta}(a\cos t+ib\sin t)$, as $t$~ranges over all
  9705. angles. Notice that if |major_axis=minor_axis=d|, we obtain a circle
  9706. of diameter~|d|, regardless of the value of |theta|.
  9707. The method sketched above is used to produce the elliptical polygon,
  9708. except that the main work is done only in the halfplane obtained from
  9709. the three starting directions $(0,-1)$, $(1,0)$,~$(0,1)$. Since the ellipse
  9710. has circular symmetry, we use the fact that the last half of the polygon
  9711. is simply the negative of the first half. Furthermore, we need to compute only
  9712. one quarter of the polygon if the ellipse has axis symmetry.
  9713. @p function make_ellipse(@!major_axis,@!minor_axis:scaled;
  9714.   @!theta:angle):pointer;
  9715. label done,done1,found;
  9716. var @!p,@!q,@!r,@!s:pointer; {for list manipulation}
  9717. @!h:pointer; {head of the constructed knot list}
  9718. @!alpha,@!beta,@!gamma,@!delta:integer; {special points}
  9719. @!c,@!d:integer; {class numbers}
  9720. @!u,@!v:integer; {directions}
  9721. @!symmetric:boolean; {should the result be symmetric about the axes?}
  9722. begin @<Initialize the ellipse data structure by beginning with
  9723.   directions $(0,-1)$, $(1,0)$, $(0,1)$@>;
  9724. @<Interpolate new vertices in the ellipse data structure until
  9725.   improvement is impossible@>;
  9726. if symmetric then
  9727.   @<Complete the half ellipse by reflecting the quarter already computed@>;
  9728. @<Complete the ellipse by copying the negative of the half already computed@>;
  9729. make_ellipse:=h;
  9730. @ A special data structure is used only with |make_ellipse|: The
  9731. |right_x|, |left_x|, |right_y|, and |left_y| fields of knot nodes
  9732. are renamed |right_u|, |left_v|, |right_class|, and |left_length|,
  9733. in order to store information that simplifies the necessary computations.
  9734. If |p| and |q| are consecutive knots in this data structure, the
  9735. |x_coord| and |y_coord| fields of |p| and~|q| contain current vertices
  9736. of the polygon; their values are integer multiples
  9737. of |half_unit|. Both of these vertices belong to equivalence class
  9738. |right_class(p)| with respect to the direction
  9739. $\bigl($|right_u(p),left_v(q)|$\bigr)$. The number of points of this class
  9740. on the line from vertex~|p| to vertex~|q| is |1+left_length(q)|.
  9741. In particular, |left_length(q)=0| means that |x_coord(p)=x_coord(q)|
  9742. and |y_coord(p)=y_coord(q)|; such duplicate vertices will be
  9743. discarded during the course of the algorithm.
  9744. The contents of |right_u(p)| and |left_v(q)| are integer multiples
  9745. of |half_unit|, just like the coordinate fields. Hence, for example,
  9746. the point $\bigl($|x_coord(p)-left_v(q),y_coord(p)+right_u(q)|$\bigr)$
  9747. also belongs to class number |right_class(p)|. This point is one
  9748. step closer to the vertex in node~|q|; it equals that vertex
  9749. if and only if |left_length(q)=1|.
  9750. The |left_type| and |right_type| fields are not used, but |link|
  9751. has its normal meaning.
  9752. To start the process, we create four nodes for the three directions
  9753. $(0,-1)$, $(1,0)$, and $(0,1)$. The corresponding vertices are
  9754. $(-\alpha,-\beta)$, $(\gamma,-\beta)$, $(\gamma,\beta)$, and
  9755. $(\alpha,\beta)$, where $(\alpha,\beta)$ is a half-integer approximation
  9756. to where the ellipse rises highest above the $x$-axis, and where
  9757. $\gamma$ is a half-integer approximation to the maximum $x$~coordinate
  9758. of the ellipse. The fourth of these nodes is not actually calculated
  9759. if the ellipse has axis symmetry.
  9760. @d right_u==right_x {|u| value for a pen edge}
  9761. @d left_v==left_x {|v| value for a pen edge}
  9762. @d right_class==right_y {equivalence class number of a pen edge}
  9763. @d left_length==left_y {length of a pen edge}
  9764. @<Initialize the ellipse data structure...@>=
  9765. @<Calculate integers $\alpha$, $\beta$, $\gamma$ for the vertex
  9766.   coordinates@>;
  9767. p:=get_node(knot_node_size); q:=get_node(knot_node_size);
  9768. r:=get_node(knot_node_size);
  9769. if symmetric then s:=null@+else s:=get_node(knot_node_size);
  9770. h:=p; link(p):=q; link(q):=r; link(r):=s; {|s=null| or |link(s)=null|}
  9771. @<Revise the values of $\alpha$, $\beta$, $\gamma$, if necessary,
  9772.   so that degenerate lines of length zero will not be obtained@>;
  9773. x_coord(p):=-alpha*half_unit;
  9774. y_coord(p):=-beta*half_unit;
  9775. x_coord(q):=gamma*half_unit;@/
  9776. y_coord(q):=y_coord(p); x_coord(r):=x_coord(q);@/
  9777. right_u(p):=0; left_v(q):=-half_unit;@/
  9778. right_u(q):=half_unit; left_v(r):=0;@/
  9779. right_u(r):=0;
  9780. right_class(p):=beta; right_class(q):=gamma; right_class(r):=beta;@/
  9781. left_length(q):=gamma+alpha;
  9782. if symmetric then
  9783.   begin y_coord(r):=0; left_length(r):=beta;
  9784.   end
  9785. else  begin y_coord(r):=-y_coord(p); left_length(r):=beta+beta;@/
  9786.   x_coord(s):=-x_coord(p); y_coord(s):=y_coord(r);@/
  9787.   left_v(s):=half_unit; left_length(s):=gamma-alpha;
  9788.   end
  9789. @ One of the important invariants of the pen data structure is that
  9790. the points are distinct. We may need to correct the pen specification
  9791. in order to avoid this. (The result of \&{pencircle} will always be at
  9792. least one pixel wide and one pixel tall, although \&{makepen} is
  9793. capable of producing smaller pens.)
  9794. @<Revise the values of $\alpha$, $\beta$, $\gamma$, if necessary...@>=
  9795. if beta=0 then beta:=1;
  9796. if gamma=0 then gamma:=1;
  9797. if gamma<=abs(alpha) then
  9798.   if alpha>0 then alpha:=gamma-1
  9799.   else alpha:=1-gamma
  9800. @ If $a$ and $b$ are the semi-major and semi-minor axes,
  9801. the given ellipse rises highest above the $y$-axis at the point
  9802. $\bigl((a^2-b^2)\sin\theta\cos\theta/\rho\bigr)+i\rho$, where
  9803. $\rho=\sqrt{(a\sin\theta)^2+(b\cos\theta)^2}$. It reaches
  9804. furthest to the right of~the $x$-axis at the point
  9805. $\sigma+i(a^2-b^2)\sin\theta\cos\theta/\sigma$, where
  9806. $\sigma=\sqrt{(a\cos\theta)^2+(b\sin\theta)^2}$.
  9807. @<Calculate integers $\alpha$, $\beta$, $\gamma$...@>=
  9808. if (major_axis=minor_axis)or(theta mod ninety_deg=0) then
  9809.   begin symmetric:=true; alpha:=0;
  9810.   if odd(theta div ninety_deg) then
  9811.     begin beta:=major_axis; gamma:=minor_axis;
  9812.     n_sin:=fraction_one; n_cos:=0; {|n_sin| and |n_cos| are used later}
  9813.     end
  9814.   else  begin beta:=minor_axis; gamma:=major_axis;
  9815.     end; {|n_sin| and |n_cos| aren't needed in this case}
  9816.   end
  9817. else  begin symmetric:=false;
  9818.   n_sin_cos(theta); {set up $|n_sin|=\sin\theta$ and $|n_cos|=\cos\theta$}
  9819.   gamma:=take_fraction(major_axis,n_sin);
  9820.   delta:=take_fraction(minor_axis,n_cos);
  9821.   beta:=pyth_add(gamma,delta);
  9822.   alpha:=take_fraction(take_fraction(major_axis,
  9823.       make_fraction(gamma,beta)),n_cos)@|
  9824.     -take_fraction(take_fraction(minor_axis,
  9825.       make_fraction(delta,beta)),n_sin);
  9826.   alpha:=(alpha+half_unit) div unity;
  9827.   gamma:=pyth_add(take_fraction(major_axis,n_cos),
  9828.     take_fraction(minor_axis,n_sin));
  9829.   end;
  9830. beta:=(beta+half_unit) div unity;
  9831. gamma:=(gamma+half_unit) div unity
  9832. @ Now |p|, |q|, and |r| march through the list, always representing
  9833. three consecutive vertices and two consecutive slope directions.
  9834. When a new slope is interpolated, we back up slightly, until
  9835. further refinement is impossible; then we march forward again.
  9836. The somewhat magical operations performed in this part of the
  9837. algorithm are justified by the theory sketched earlier.
  9838. Complications arise only from the need to keep zero-length lines
  9839. out of the final data structure.
  9840. @<Interpolate new vertices in the ellipse data structure...@>=
  9841. loop@+  begin u:=right_u(p)+right_u(q); v:=left_v(q)+left_v(r);
  9842.   c:=right_class(p)+right_class(q);@/
  9843.   @<Compute the distance |d| from class~0 to the edge of the ellipse
  9844.     in direction |(u,v)|, times $\psqrt{u^2+v^2}$,
  9845.     rounded to the nearest integer@>;
  9846.   delta:=c-d; {we want to move |delta| steps back
  9847.       from the intersection vertex~|q|}
  9848.   if delta>0 then
  9849.     begin if delta>left_length(r) then delta:=left_length(r);
  9850.     if delta>=left_length(q) then
  9851.       @<Remove the line from |p| to |q|,
  9852.         and adjust vertex~|q| to introduce a new line@>
  9853.     else @<Insert a new line for direction |(u,v)| between |p| and~|q|@>;
  9854.     end
  9855.   else p:=q;
  9856.   @<Move to the next remaining triple |(p,q,r)|, removing and skipping past
  9857.     zero-length lines that might be present; |goto done| if all
  9858.     triples have been processed@>;
  9859.   end;
  9860. done:
  9861. @ The appearance of a zero-length line means that we should advance |p|
  9862. past it. We must not try to straddle a missing direction, because the
  9863. algorithm works only on consecutive pairs of directions.
  9864. @<Move to the next remaining triple |(p,q,r)|...@>=
  9865. loop@+  begin q:=link(p);
  9866.   if q=null then goto done;
  9867.   if left_length(q)=0 then
  9868.     begin link(p):=link(q); right_class(p):=right_class(q);
  9869.     right_u(p):=right_u(q); free_node(q,knot_node_size);
  9870.     end
  9871.   else  begin r:=link(q);
  9872.     if r=null then goto done;
  9873.     if left_length(r)=0 then
  9874.       begin link(p):=r; free_node(q,knot_node_size); p:=r;
  9875.       end
  9876.     else goto found;
  9877.     end;
  9878.   end;
  9879. found:
  9880. @ The `\&{div} 8' near the end of this step comes from
  9881. the fact that |delta| is scaled by~$2^{15}$ and $d$~by~$2^{16}$,
  9882. while |take_fraction| removes a scale factor of~$2^{28}$.
  9883. We also make sure that $d\G\max(\vert u\vert,\vert v\vert)$, so that
  9884. the pen will always include a circular pen of diameter~1 as a subset;
  9885. then it won't be possible to get disconnected path envelopes.
  9886. @<Compute the distance |d| from class~0 to the edge of the ellipse...@>=
  9887. delta:=pyth_add(u,v);
  9888. if major_axis=minor_axis then d:=major_axis {circles are easy}
  9889. else  begin if theta=0 then
  9890.     begin alpha:=u; beta:=v;
  9891.     end
  9892.   else  begin alpha:=take_fraction(u,n_cos)+take_fraction(v,n_sin);
  9893.     beta:=take_fraction(v,n_cos)-take_fraction(u,n_sin);
  9894.     end;
  9895.   alpha:=make_fraction(alpha,delta);
  9896.   beta:=make_fraction(beta,delta);
  9897.   d:=pyth_add(take_fraction(major_axis,alpha),
  9898.     take_fraction(minor_axis,beta));
  9899.   end;
  9900. alpha:=abs(u); beta:=abs(v);
  9901. if alpha<beta then
  9902.   begin alpha:=abs(v); beta:=abs(u);
  9903.   end; {now $\alpha=\max(\vert u\vert,\vert v\vert)$,
  9904.       $\beta=\min(\vert u\vert,\vert v\vert)$}
  9905. if internal[fillin]<>0 then
  9906.   d:=d-take_fraction(internal[fillin],make_fraction(beta+beta,delta));
  9907. d:=take_fraction((d+4) div 8,delta); alpha:=alpha div half_unit;
  9908. if d<alpha then d:=alpha
  9909. @ At this point there's a line of length |<=delta| from vertex~|p|
  9910. to vertex~|q|, orthogonal to direction $\bigl($|right_u(p),left_v(q)|$\bigr)$;
  9911. and there's a line of length |>=delta| from vertex~|q| to
  9912. to vertex~|r|, orthogonal to direction $\bigl($|right_u(q),left_v(r)|$\bigr)$.
  9913. The best line to direction $(u,v)$ should replace the line from
  9914. |p| to~|q|; this new line will have the same length as the old.
  9915. @<Remove the line from |p| to |q|...@>=
  9916. begin delta:=left_length(q);@/
  9917. right_class(p):=c-delta; right_u(p):=u; left_v(q):=v;@/
  9918. x_coord(q):=x_coord(q)-delta*left_v(r);
  9919. y_coord(q):=y_coord(q)+delta*right_u(q);@/
  9920. left_length(r):=left_length(r)-delta;
  9921. @ Here is the main case, now that we have dealt with the exception:
  9922. We insert a new line of length |delta| for direction |(u,v)|, decreasing
  9923. each of the adjacent lines by |delta| steps.
  9924. @<Insert a new line for direction |(u,v)| between |p| and~|q|@>=
  9925. begin s:=get_node(knot_node_size); link(p):=s; link(s):=q;@/
  9926. x_coord(s):=x_coord(q)+delta*left_v(q);
  9927. y_coord(s):=y_coord(q)-delta*right_u(p);@/
  9928. x_coord(q):=x_coord(q)-delta*left_v(r);
  9929. y_coord(q):=y_coord(q)+delta*right_u(q);@/
  9930. left_v(s):=left_v(q); right_u(s):=u; left_v(q):=v;@/
  9931. right_class(s):=c-delta;@/
  9932. left_length(s):=left_length(q)-delta; left_length(q):=delta;
  9933. left_length(r):=left_length(r)-delta;
  9934. @ Only the coordinates need to be copied, not the class numbers and other stuff.
  9935. @<Complete the half ellipse...@>=
  9936. begin s:=null; q:=h;
  9937. loop@+  begin r:=get_node(knot_node_size); link(r):=s; s:=r;@/
  9938.   x_coord(s):=x_coord(q); y_coord(s):=-y_coord(q);
  9939.   if q=p then goto done1;
  9940.   q:=link(q);
  9941.   if y_coord(q)=0 then goto done1;
  9942.   end;
  9943. done1: link(p):=s; beta:=-y_coord(h);
  9944. while y_coord(p)<>beta do p:=link(p);
  9945. q:=link(p);
  9946. @ Now we use a somewhat tricky fact: The pointer |q| will be null if and
  9947. only if the line for the final direction $(0,1)$ has been removed. If
  9948. that line still survives, it should be combined with a possibly
  9949. surviving line in the initial direction $(0,-1)$.
  9950. @<Complete the ellipse by copying...@>=
  9951. if q<>null then
  9952.   begin if right_u(h)=0 then
  9953.     begin p:=h; h:=link(h); free_node(p,knot_node_size);@/
  9954.     x_coord(q):=-x_coord(h);
  9955.     end;
  9956.   p:=q;
  9957.   end
  9958. else q:=p;
  9959. r:=link(h); {now |p=q|, |x_coord(p)=-x_coord(h)|, |y_coord(p)=-y_coord(h)|}
  9960. repeat s:=get_node(knot_node_size); link(p):=s; p:=s;@/
  9961. x_coord(p):=-x_coord(r); y_coord(p):=-y_coord(r); r:=link(r);
  9962. until r=q;
  9963. link(p):=h
  9964. @* \[26] Direction and intersection times.
  9965. A path of length $n$ is defined parametrically by functions $x(t)$ and
  9966. $y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path
  9967. reaches the point $\bigl(x(t),y(t)\bigr)$.  In this section of the program
  9968. we shall consider operations that determine special times associated with
  9969. given paths: the first time that a path travels in a given direction, and
  9970. a pair of times at which two paths cross each other.
  9971. @ Let's start with the easier task. The function |find_direction_time| is
  9972. given a direction |(x,y)| and a path starting at~|h|. If the path never
  9973. travels in direction |(x,y)|, the direction time will be~|-1|; otherwise
  9974. it will be nonnegative.
  9975. Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given
  9976. direction is undefined, the direction time will be~0. If $\bigl(x'(t),
  9977. y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be
  9978. assumed to match any given direction at time~|t|.
  9979. The routine solves this problem in nondegenerate cases by rotating the path
  9980. and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be
  9981. to find when a given path first travels ``due east.''
  9982. @p function find_direction_time(@!x,@!y:scaled;@!h:pointer):scaled;
  9983. label exit,found,not_found,done;
  9984. var @!max:scaled; {$\max\bigl(\vert x\vert,\vert y\vert\bigr)$}
  9985. @!p,@!q:pointer; {for list traversal}
  9986. @!n:scaled; {the direction time at knot |p|}
  9987. @!tt:scaled; {the direction time within a cubic}
  9988. @<Other local variables for |find_direction_time|@>@;
  9989. begin @<Normalize the given direction for better accuracy;
  9990.   but |return| with zero result if it's zero@>;
  9991. n:=0; p:=h;
  9992. loop@+  begin if right_type(p)=endpoint then goto not_found;
  9993.   q:=link(p);
  9994.   @<Rotate the cubic between |p| and |q|; then
  9995.     |goto found| if the rotated cubic travels due east at some time |tt|;
  9996.     but |goto not_found| if an entire cyclic path has been traversed@>;
  9997.   p:=q; n:=n+unity;
  9998.   end;
  9999. not_found: find_direction_time:=-unity; return;
  10000. found: find_direction_time:=n+tt;
  10001. exit:end;
  10002. @ @<Normalize the given direction for better accuracy...@>=
  10003. if abs(x)<abs(y) then
  10004.   begin x:=make_fraction(x,abs(y));
  10005.   if y>0 then y:=fraction_one@+else y:=-fraction_one;
  10006.   end
  10007. else if x=0 then
  10008.   begin find_direction_time:=0; return;
  10009.   end
  10010. else  begin y:=make_fraction(y,abs(x));
  10011.   if x>0 then x:=fraction_one@+else x:=-fraction_one;
  10012.   end
  10013. @ Since we're interested in the tangent directions, we work with the
  10014. derivative $${\textstyle1\over3}B'(x_0,x_1,x_2,x_3;t)=
  10015. B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of
  10016. $B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up
  10017. in order to achieve better accuracy.
  10018. The given path may turn abruptly at a knot, and it might pass the critical
  10019. tangent direction at such a time. Therefore we remember the direction |phi|
  10020. in which the previous rotated cubic was traveling. (The value of |phi| will be
  10021. undefined on the first cubic, i.e., when |n=0|.)
  10022. @<Rotate the cubic between |p| and |q|; then...@>=
  10023. tt:=0;
  10024. @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control
  10025.   points of the rotated derivatives@>;
  10026. if y1=0 then if x1>=0 then goto found;
  10027. if n>0 then
  10028.   begin @<Exit to |found| if an eastward direction occurs at knot |p|@>;
  10029.   if p=h then goto not_found;
  10030.   end;
  10031. if (x3<>0)or(y3<>0) then phi:=n_arg(x3,y3);
  10032. @<Exit to |found| if the curve whose derivatives are specified by
  10033.   |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@>
  10034. @ @<Other local variables for |find_direction_time|@>=
  10035. @!x1,@!x2,@!x3,@!y1,@!y2,@!y3:scaled; {multiples of rotated derivatives}
  10036. @!theta,@!phi:angle; {angles of exit and entry at a knot}
  10037. @!t:fraction; {temp storage}
  10038. @ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>=
  10039. x1:=right_x(p)-x_coord(p); x2:=left_x(q)-right_x(p);
  10040. x3:=x_coord(q)-left_x(q);@/
  10041. y1:=right_y(p)-y_coord(p); y2:=left_y(q)-right_y(p);
  10042. y3:=y_coord(q)-left_y(q);@/
  10043. max:=abs(x1);
  10044. if abs(x2)>max then max:=abs(x2);
  10045. if abs(x3)>max then max:=abs(x3);
  10046. if abs(y1)>max then max:=abs(y1);
  10047. if abs(y2)>max then max:=abs(y2);
  10048. if abs(y3)>max then max:=abs(y3);
  10049. if max=0 then goto found;
  10050. while max<fraction_half do
  10051.   begin double(max); double(x1); double(x2); double(x3);
  10052.   double(y1); double(y2); double(y3);
  10053.   end;
  10054. t:=x1; x1:=take_fraction(x1,x)+take_fraction(y1,y);
  10055. y1:=take_fraction(y1,x)-take_fraction(t,y);@/
  10056. t:=x2; x2:=take_fraction(x2,x)+take_fraction(y2,y);
  10057. y2:=take_fraction(y2,x)-take_fraction(t,y);@/
  10058. t:=x3; x3:=take_fraction(x3,x)+take_fraction(y3,y);
  10059. y3:=take_fraction(y3,x)-take_fraction(t,y)
  10060. @ @<Exit to |found| if an eastward direction occurs at knot |p|@>=
  10061. theta:=n_arg(x1,y1);
  10062. if theta>=0 then if phi<=0 then if phi>=theta-one_eighty_deg then goto found;
  10063. if theta<=0 then if phi>=0 then if phi<=theta+one_eighty_deg then goto found
  10064. @ In this step we want to use the |crossing_point| routine to find the
  10065. roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$.
  10066. Several complications arise: If the quadratic equation has a double root,
  10067. the curve never crosses zero, and |crossing_point| will find nothing;
  10068. this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic
  10069. equation has simple roots, or only one root, we may have to negate it
  10070. so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root.
  10071. And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is
  10072. identically zero.
  10073. @ @<Exit to |found| if the curve whose derivatives are specified by...@>=
  10074. if x1<0 then if x2<0 then if x3<0 then goto done;
  10075. if ab_vs_cd(y1,y3,y2,y2)=0 then
  10076.   @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
  10077.     either |goto found| or |goto done|@>;
  10078. if y1<=0 then
  10079.   if y1<0 then
  10080.     begin y1:=-y1; y2:=-y2; y3:=-y3;
  10081.     end
  10082.   else if y2>0 then
  10083.     begin y2:=-y2; y3:=-y3;
  10084.     end;
  10085. @<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if
  10086.   $B(x_1,x_2,x_3;t)\ge0$@>;
  10087. done:
  10088. @ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most
  10089. two roots, because we know that it isn't identically zero.
  10090. It must be admitted that the |crossing_point| routine is not perfectly accurate;
  10091. rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to
  10092. miss the roots when $y_1y_3<y_2^2$. The rotation process is itself
  10093. subject to rounding errors. Yet this code optimistically tries to
  10094. do the right thing.
  10095. @d we_found_it==begin tt:=(t+@'4000) div @'10000; goto found;
  10096.   end
  10097. @<Check the places where $B(y_1,y_2,y_3;t)=0$...@>=
  10098. t:=crossing_point(y1,y2,y3);
  10099. if t>fraction_one then goto done;
  10100. y2:=t_of_the_way(y2)(y3);
  10101. x1:=t_of_the_way(x1)(x2);
  10102. x2:=t_of_the_way(x2)(x3);
  10103. x1:=t_of_the_way(x1)(x2);
  10104. if x1>=0 then we_found_it;
  10105. if y2>0 then y2:=0;
  10106. tt:=t; t:=crossing_point(0,-y2,-y3);
  10107. if t>fraction_one then goto done;
  10108. x1:=t_of_the_way(x1)(x2);
  10109. x2:=t_of_the_way(x2)(x3);
  10110. if t_of_the_way(x1)(x2)>=0 then
  10111.   begin t:=t_of_the_way(tt)(fraction_one); we_found_it;
  10112.   end
  10113. @ @<Handle the test for eastward directions when $y_1y_3=y_2^2$;
  10114.     either |goto found| or |goto done|@>=
  10115. begin if ab_vs_cd(y1,y2,0,0)<0 then
  10116.   begin t:=make_fraction(y1,y1-y2);
  10117.   x1:=t_of_the_way(x1)(x2);
  10118.   x2:=t_of_the_way(x2)(x3);
  10119.   if t_of_the_way(x1)(x2)>=0 then we_found_it;
  10120.   end
  10121. else if y3=0 then
  10122.   if y1=0 then
  10123.     @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@>
  10124.   else if x3>=0 then
  10125.     begin tt:=unity; goto found;
  10126.     end;
  10127. goto done;
  10128. @ At this point we know that the derivative of |y(t)| is identically zero,
  10129. and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of
  10130. traveling east.
  10131. @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>=
  10132. begin t:=crossing_point(-x1,-x2,-x3);
  10133. if t<=fraction_one then we_found_it;
  10134. if ab_vs_cd(x1,x3,x2,x2)<=0 then
  10135.   begin t:=make_fraction(x1,x1-x2); we_found_it;
  10136.   end;
  10137. @ The intersection of two cubics can be found by an interesting variant
  10138. of the general bisection scheme described in the introduction to |make_moves|.\
  10139. Given $w(t)=B(w_0,w_1,w_2,w_3;t)$ and $z(t)=B(z_0,z_1,z_2,z_3;t)$,
  10140. we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$,
  10141. if an intersection exists. First we find the smallest rectangle that
  10142. encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps
  10143. the smallest rectangle that encloses
  10144. $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect.
  10145. But if the rectangles do overlap, we bisect the intervals, getting
  10146. new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first
  10147. tries for an intersection between $w'$ and~$z'$, then (if unsuccessful)
  10148. between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$,
  10149. finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful
  10150. levels of bisection we will have determined the intersection times $t_1$
  10151. and~$t_2$ to $l$~bits of accuracy.
  10152. \def\submin{_{\rm min}} \def\submax{_{\rm max}}
  10153. As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$
  10154. and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$
  10155. themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$,
  10156. to determine when the enclosing rectangles overlap. Here's why:
  10157. The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$,
  10158. and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$,
  10159. if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin=
  10160. \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates
  10161. overlap if and only if $u\submin\L x\submax$ and
  10162. $x\submin\L u\submax$. Letting
  10163. $$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\;
  10164.   U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$
  10165. we have $u\submin=2^lu_0+U\submin$, etc.; the condition for overlap
  10166. reduces to
  10167. $$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$
  10168. Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly,
  10169. the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The
  10170. coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases,
  10171. because of the overlap condition; i.e., we know that $X\submin$,
  10172. $X\submax$, and their relatives are bounded, hence $X\submax-
  10173. U\submin$ and $X\submin-U\submax$ are bounded.
  10174. @ Incidentally, if the given cubics intersect more than once, the process
  10175. just sketched will not necessarily find the lexicographically smallest pair
  10176. $(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled
  10177. order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and
  10178. $t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize
  10179. $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not
  10180. $a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$.
  10181. Shuffled order agrees with lexicographic order if all pairs of solutions
  10182. $(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff
  10183. $t_2<t_2'$; but in general, lexicographic order can be quite different,
  10184. and the bisection algorithm would be substantially less efficient if it were
  10185. constrained by lexicographic order.
  10186. For example, suppose that an overlap has been found for $l=3$ and
  10187. $(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by
  10188. either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4.
  10189. Then there is probably an intersection in one of the subintervals
  10190. $(.1011,.011x)$; but lexicographic order would require us to explore
  10191. $(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't
  10192. want to store all of the subdivision data for the second path, so the
  10193. subdivisions would have to be regenerated many times. Such inefficiencies
  10194. would be associated with every `1' in the binary representation of~$t_1$.
  10195. @ The subdivision process introduces rounding errors, hence we need to
  10196. make a more liberal test for overlap. It is not hard to show that the
  10197. computed values of $U_i$ differ from the truth by at most~$l$, on
  10198. level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error.
  10199. If $\beta$ is an upper bound on the absolute error in the computed
  10200. components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace
  10201. the test `$X\submin-U\submax\L|delx|$' by the more liberal test
  10202. `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$.
  10203. More accuracy is obtained if we try the algorithm first with |tol=0|;
  10204. the more liberal tolerance is used only if an exact approach fails.
  10205. It is convenient to do this double-take by letting `3' in the preceding
  10206. paragraph be a parameter, which is first 0, then 3.
  10207. @<Glob...@>=
  10208. @!tol_step:0..6; {either 0 or 3, usually}
  10209. @ We shall use an explicit stack to implement the recursive bisection
  10210. method described above. In fact, the |bisect_stack| array is available for
  10211. this purpose. It will contain numerous 5-word packets like
  10212. $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets comprising
  10213. the 5-word packets for $U$, $V$, $X$, and~$Y$.
  10214. The following macros define the allocation of stack positions to
  10215. the quantities needed for bisection-intersection.
  10216. @d stack_1(#)==bisect_stack[#] {$U_1$, $V_1$, $X_1$, or $Y_1$}
  10217. @d stack_2(#)==bisect_stack[#+1] {$U_2$, $V_2$, $X_2$, or $Y_2$}
  10218. @d stack_3(#)==bisect_stack[#+2] {$U_3$, $V_3$, $X_3$, or $Y_3$}
  10219. @d stack_min(#)==bisect_stack[#+3]
  10220.   {$U\submin$, $V\submin$, $X\submin$, or $Y\submin$}
  10221. @d stack_max(#)==bisect_stack[#+4]
  10222.   {$U\submax$, $V\submax$, $X\submax$, or $Y\submax$}
  10223. @d int_packets=20 {number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$}
  10224. @d u_packet(#)==#-5
  10225. @d v_packet(#)==#-10
  10226. @d x_packet(#)==#-15
  10227. @d y_packet(#)==#-20
  10228. @d l_packets==bisect_ptr-int_packets
  10229. @d r_packets==bisect_ptr
  10230. @d ul_packet==u_packet(l_packets) {base of $U'_k$ variables}
  10231. @d vl_packet==v_packet(l_packets) {base of $V'_k$ variables}
  10232. @d xl_packet==x_packet(l_packets) {base of $X'_k$ variables}
  10233. @d yl_packet==y_packet(l_packets) {base of $Y'_k$ variables}
  10234. @d ur_packet==u_packet(r_packets) {base of $U''_k$ variables}
  10235. @d vr_packet==v_packet(r_packets) {base of $V''_k$ variables}
  10236. @d xr_packet==x_packet(r_packets) {base of $X''_k$ variables}
  10237. @d yr_packet==y_packet(r_packets) {base of $Y''_k$ variables}
  10238. @d u1l==stack_1(ul_packet) {$U'_1$}
  10239. @d u2l==stack_2(ul_packet) {$U'_2$}
  10240. @d u3l==stack_3(ul_packet) {$U'_3$}
  10241. @d v1l==stack_1(vl_packet) {$V'_1$}
  10242. @d v2l==stack_2(vl_packet) {$V'_2$}
  10243. @d v3l==stack_3(vl_packet) {$V'_3$}
  10244. @d x1l==stack_1(xl_packet) {$X'_1$}
  10245. @d x2l==stack_2(xl_packet) {$X'_2$}
  10246. @d x3l==stack_3(xl_packet) {$X'_3$}
  10247. @d y1l==stack_1(yl_packet) {$Y'_1$}
  10248. @d y2l==stack_2(yl_packet) {$Y'_2$}
  10249. @d y3l==stack_3(yl_packet) {$Y'_3$}
  10250. @d u1r==stack_1(ur_packet) {$U''_1$}
  10251. @d u2r==stack_2(ur_packet) {$U''_2$}
  10252. @d u3r==stack_3(ur_packet) {$U''_3$}
  10253. @d v1r==stack_1(vr_packet) {$V''_1$}
  10254. @d v2r==stack_2(vr_packet) {$V''_2$}
  10255. @d v3r==stack_3(vr_packet) {$V''_3$}
  10256. @d x1r==stack_1(xr_packet) {$X''_1$}
  10257. @d x2r==stack_2(xr_packet) {$X''_2$}
  10258. @d x3r==stack_3(xr_packet) {$X''_3$}
  10259. @d y1r==stack_1(yr_packet) {$Y''_1$}
  10260. @d y2r==stack_2(yr_packet) {$Y''_2$}
  10261. @d y3r==stack_3(yr_packet) {$Y''_3$}
  10262. @d stack_dx==bisect_stack[bisect_ptr] {stacked value of |delx|}
  10263. @d stack_dy==bisect_stack[bisect_ptr+1] {stacked value of |dely|}
  10264. @d stack_tol==bisect_stack[bisect_ptr+2] {stacked value of |tol|}
  10265. @d stack_uv==bisect_stack[bisect_ptr+3] {stacked value of |uv|}
  10266. @d stack_xy==bisect_stack[bisect_ptr+4] {stacked value of |xy|}
  10267. @d int_increment=int_packets+int_packets+5 {number of stack words per level}
  10268. @<Check the ``constant''...@>=
  10269. if int_packets+17*int_increment>bistack_size then bad:=32;
  10270. @ Computation of the min and max is a tedious but fairly fast sequence of
  10271. instructions; exactly four comparisons are made in each branch.
  10272. @d set_min_max(#)==
  10273.   if stack_1(#)<0 then
  10274.     if stack_3(#)>=0 then
  10275.       begin if stack_2(#)<0 then stack_min(#):=stack_1(#)+stack_2(#)
  10276.         else stack_min(#):=stack_1(#);
  10277.       stack_max(#):=stack_1(#)+stack_2(#)+stack_3(#);
  10278.       if stack_max(#)<0 then stack_max(#):=0;
  10279.       end
  10280.     else  begin stack_min(#):=stack_1(#)+stack_2(#)+stack_3(#);
  10281.       if stack_min(#)>stack_1(#) then stack_min(#):=stack_1(#);
  10282.       stack_max(#):=stack_1(#)+stack_2(#);
  10283.       if stack_max(#)<0 then stack_max(#):=0;
  10284.       end
  10285.   else if stack_3(#)<=0 then
  10286.     begin if stack_2(#)>0 then stack_max(#):=stack_1(#)+stack_2(#)
  10287.       else stack_max(#):=stack_1(#);
  10288.     stack_min(#):=stack_1(#)+stack_2(#)+stack_3(#);
  10289.     if stack_min(#)>0 then stack_min(#):=0;
  10290.     end
  10291.   else  begin stack_max(#):=stack_1(#)+stack_2(#)+stack_3(#);
  10292.     if stack_max(#)<stack_1(#) then stack_max(#):=stack_1(#);
  10293.     stack_min(#):=stack_1(#)+stack_2(#);
  10294.     if stack_min(#)>0 then stack_min(#):=0;
  10295.     end
  10296. @ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in
  10297. the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection|
  10298. routine uses global variables |cur_t| and |cur_tt| for this purpose;
  10299. after successful completion, |cur_t| and |cur_tt| will contain |unity|
  10300. plus the |scaled| values of $t_1$ and~$t_2$.
  10301. The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection|
  10302. finds no intersection. The routine gives up and gives an approximate answer
  10303. if it has backtracked
  10304. more than 5000 times (otherwise there are cases where several minutes
  10305. of fruitless computation would be possible).
  10306. @d max_patience=5000
  10307. @<Glob...@>=
  10308. @!cur_t,@!cur_tt:integer; {controls and results of |cubic_intersection|}
  10309. @!time_to_go:integer; {this many backtracks before giving up}
  10310. @!max_t:integer; {maximum of $2^{l+1}$ so far achieved}
  10311. @ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and
  10312. $B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))|
  10313. and |(pp,link(pp))|, respectively.
  10314. @p procedure cubic_intersection(@!p,@!pp:pointer);
  10315. label continue, not_found, exit;
  10316. var @!q,@!qq:pointer; {|link(p)|, |link(pp)|}
  10317. begin time_to_go:=max_patience; max_t:=2;
  10318. @<Initialize for intersections at level zero@>;
  10319. loop@+  begin continue:
  10320.   if delx-tol<=stack_max(x_packet(xy))-stack_min(u_packet(uv)) then
  10321.    if delx+tol>=stack_min(x_packet(xy))-stack_max(u_packet(uv)) then
  10322.    if dely-tol<=stack_max(y_packet(xy))-stack_min(v_packet(uv)) then
  10323.    if dely+tol>=stack_min(y_packet(xy))-stack_max(v_packet(uv)) then
  10324.     begin if cur_t>=max_t then
  10325.       begin if max_t=two then {we've done 17 bisections}
  10326.         begin cur_t:=half(cur_t+1); cur_tt:=half(cur_tt+1); return;
  10327.         end;
  10328.       double(max_t); appr_t:=cur_t; appr_tt:=cur_tt;
  10329.       end;
  10330.     @<Subdivide for a new level of intersection@>;
  10331.     goto continue;
  10332.     end;
  10333.   if time_to_go>0 then decr(time_to_go)
  10334.   else  begin while appr_t<unity do
  10335.       begin double(appr_t); double(appr_tt);
  10336.       end;
  10337.     cur_t:=appr_t; cur_tt:=appr_tt; return;
  10338.     end;
  10339.   @<Advance to the next pair |(cur_t,cur_tt)|@>;
  10340.   end;
  10341. exit:end;
  10342. @ The following variables are global, although they are used only by
  10343. |cubic_intersection|, because it is necessary on some machines to
  10344. split |cubic_intersection| up into two procedures.
  10345. @<Glob...@>=
  10346. @!delx,@!dely:integer; {the components of $\Delta=2^l(w_0-z_0)$}
  10347. @!tol:integer; {bound on the uncertainly in the overlap test}
  10348. @!uv,@!xy:0..bistack_size; {pointers to the current packets of interest}
  10349. @!three_l:integer; {|tol_step| times the bisection level}
  10350. @!appr_t,@!appr_tt:integer; {best approximations known to the answers}
  10351. @ We shall assume that the coordinates are sufficiently non-extreme that
  10352. integer overflow will not occur.
  10353. @<Initialize for intersections at level zero@>=
  10354. q:=link(p); qq:=link(pp); bisect_ptr:=int_packets;@/
  10355. u1r:=right_x(p)-x_coord(p); u2r:=left_x(q)-right_x(p);
  10356. u3r:=x_coord(q)-left_x(q); set_min_max(ur_packet);@/
  10357. v1r:=right_y(p)-y_coord(p); v2r:=left_y(q)-right_y(p);
  10358. v3r:=y_coord(q)-left_y(q); set_min_max(vr_packet);@/
  10359. x1r:=right_x(pp)-x_coord(pp); x2r:=left_x(qq)-right_x(pp);
  10360. x3r:=x_coord(qq)-left_x(qq); set_min_max(xr_packet);@/
  10361. y1r:=right_y(pp)-y_coord(pp); y2r:=left_y(qq)-right_y(pp);
  10362. y3r:=y_coord(qq)-left_y(qq); set_min_max(yr_packet);@/
  10363. delx:=x_coord(p)-x_coord(pp); dely:=y_coord(p)-y_coord(pp);@/
  10364. tol:=0; uv:=r_packets; xy:=r_packets; three_l:=0; cur_t:=1; cur_tt:=1
  10365. @ @<Subdivide for a new level of intersection@>=
  10366. stack_dx:=delx; stack_dy:=dely; stack_tol:=tol; stack_uv:=uv; stack_xy:=xy;
  10367. bisect_ptr:=bisect_ptr+int_increment;@/
  10368. double(cur_t); double(cur_tt);@/
  10369. u1l:=stack_1(u_packet(uv)); u3r:=stack_3(u_packet(uv));
  10370. u2l:=half(u1l+stack_2(u_packet(uv)));
  10371. u2r:=half(u3r+stack_2(u_packet(uv)));
  10372. u3l:=half(u2l+u2r); u1r:=u3l;
  10373. set_min_max(ul_packet); set_min_max(ur_packet);@/
  10374. v1l:=stack_1(v_packet(uv)); v3r:=stack_3(v_packet(uv));
  10375. v2l:=half(v1l+stack_2(v_packet(uv)));
  10376. v2r:=half(v3r+stack_2(v_packet(uv)));
  10377. v3l:=half(v2l+v2r); v1r:=v3l;
  10378. set_min_max(vl_packet); set_min_max(vr_packet);@/
  10379. x1l:=stack_1(x_packet(xy)); x3r:=stack_3(x_packet(xy));
  10380. x2l:=half(x1l+stack_2(x_packet(xy)));
  10381. x2r:=half(x3r+stack_2(x_packet(xy)));
  10382. x3l:=half(x2l+x2r); x1r:=x3l;
  10383. set_min_max(xl_packet); set_min_max(xr_packet);@/
  10384. y1l:=stack_1(y_packet(xy)); y3r:=stack_3(y_packet(xy));
  10385. y2l:=half(y1l+stack_2(y_packet(xy)));
  10386. y2r:=half(y3r+stack_2(y_packet(xy)));
  10387. y3l:=half(y2l+y2r); y1r:=y3l;
  10388. set_min_max(yl_packet); set_min_max(yr_packet);@/
  10389. uv:=l_packets; xy:=l_packets;
  10390. double(delx); double(dely);@/
  10391. tol:=tol-three_l+tol_step; double(tol); three_l:=three_l+tol_step
  10392. @ @<Advance to the next pair |(cur_t,cur_tt)|@>=
  10393. not_found: if odd(cur_tt) then
  10394.   if odd(cur_t) then @<Descend to the previous level and |goto not_found|@>
  10395.   else  begin incr(cur_t);
  10396.     delx:=delx+stack_1(u_packet(uv))+stack_2(u_packet(uv))
  10397.       +stack_3(u_packet(uv));
  10398.     dely:=dely+stack_1(v_packet(uv))+stack_2(v_packet(uv))
  10399.       +stack_3(v_packet(uv));
  10400.     uv:=uv+int_packets; {switch from |l_packet| to |r_packet|}
  10401.     decr(cur_tt); xy:=xy-int_packets; {switch from |r_packet| to |l_packet|}
  10402.     delx:=delx+stack_1(x_packet(xy))+stack_2(x_packet(xy))
  10403.       +stack_3(x_packet(xy));
  10404.     dely:=dely+stack_1(y_packet(xy))+stack_2(y_packet(xy))
  10405.       +stack_3(y_packet(xy));
  10406.     end
  10407. else  begin incr(cur_tt); tol:=tol+three_l;
  10408.   delx:=delx-stack_1(x_packet(xy))-stack_2(x_packet(xy))
  10409.     -stack_3(x_packet(xy));
  10410.   dely:=dely-stack_1(y_packet(xy))-stack_2(y_packet(xy))
  10411.     -stack_3(y_packet(xy));
  10412.   xy:=xy+int_packets; {switch from |l_packet| to |r_packet|}
  10413.   end
  10414. @ @<Descend to the previous level...@>=
  10415. begin cur_t:=half(cur_t); cur_tt:=half(cur_tt);
  10416. if cur_t=0 then return;
  10417. bisect_ptr:=bisect_ptr-int_increment; three_l:=three_l-tol_step;
  10418. delx:=stack_dx; dely:=stack_dy; tol:=stack_tol; uv:=stack_uv; xy:=stack_xy;@/
  10419. goto not_found;
  10420. @ The |path_intersection| procedure is much simpler.
  10421. It invokes |cubic_intersection| in lexicographic order until finding a
  10422. pair of cubics that intersect. The final intersection times are placed in
  10423. |cur_t| and~|cur_tt|.
  10424. @p procedure path_intersection(@!h,@!hh:pointer);
  10425. label exit;
  10426. var @!p,@!pp:pointer; {link registers that traverse the given paths}
  10427. @!n,@!nn:integer; {integer parts of intersection times, minus |unity|}
  10428. begin @<Change one-point paths into dead cycles@>;
  10429. tol_step:=0;
  10430. repeat n:=-unity; p:=h;
  10431.   repeat if right_type(p)<>endpoint then
  10432.     begin nn:=-unity; pp:=hh;
  10433.     repeat if right_type(pp)<>endpoint then
  10434.       begin cubic_intersection(p,pp);
  10435.       if cur_t>0 then
  10436.         begin cur_t:=cur_t+n; cur_tt:=cur_tt+nn; return;
  10437.         end;
  10438.       end;
  10439.     nn:=nn+unity; pp:=link(pp);
  10440.     until pp=hh;
  10441.     end;
  10442.   n:=n+unity; p:=link(p);
  10443.   until p=h;
  10444. tol_step:=tol_step+3;
  10445. until tol_step>3;
  10446. cur_t:=-unity; cur_tt:=-unity;
  10447. exit:end;
  10448. @ @<Change one-point paths...@>=
  10449. if right_type(h)=endpoint then
  10450.   begin right_x(h):=x_coord(h); left_x(h):=x_coord(h);
  10451.   right_y(h):=y_coord(h); left_y(h):=y_coord(h); right_type(h):=explicit;
  10452.   end;
  10453. if right_type(hh)=endpoint then
  10454.   begin right_x(hh):=x_coord(hh); left_x(hh):=x_coord(hh);
  10455.   right_y(hh):=y_coord(hh); left_y(hh):=y_coord(hh); right_type(hh):=explicit;
  10456.   end;
  10457. @* \[27] Online graphic output.
  10458. \MF\ displays images on the user's screen by means of a few primitive
  10459. operations that are defined below. These operations have deliberately been
  10460. kept simple so that they can be implemented without great difficulty on a
  10461. wide variety of machines. Since \PASCAL\ has no traditional standards for
  10462. graphic output, some system-dependent code needs to be written in order to
  10463. support this aspect of \MF; but the necessary routines are usually quite
  10464. easy to write.
  10465. @^system dependencies@>
  10466. In fact, there are exactly four such routines:
  10467. \yskip\hang
  10468. |init_screen| does whatever initialization is necessary to
  10469. support the other operations; it is a boolean function that returns
  10470. |false| if graphic output cannot be supported (e.g., if the other three
  10471. routines have not been written, or if the user doesn't have the
  10472. right kind of terminal).
  10473. \yskip\hang
  10474. |blank_rectangle| updates a buffer area in memory so that
  10475. all pixels in a specified rectangle will be set to the background color.
  10476. \yskip\hang
  10477. |paint_row| assigns values to specified pixels in a row of
  10478. the buffer just mentioned, based on ``transition'' indices explained below.
  10479. \yskip\hang
  10480. |update_screen| displays the current screen buffer; the
  10481. effects of |blank_rectangle| and |paint_row| commands may or may not
  10482. become visible until the next |update_screen| operation is performed.
  10483. (Thus, |update_screen| is analogous to |update_terminal|.)
  10484. \yskip\noindent
  10485. The \PASCAL\ code here is a minimum version of |init_screen| and
  10486. |update_screen|, usable on \MF\ installations that don't
  10487. support screen output. If |init_screen| is changed to return |true|
  10488. instead of |false|, the other routines will simply log the fact
  10489. that they have been called; they won't really display anything.
  10490. The standard test routines for \MF\ use this log information to check
  10491. that \MF\ is working properly, but the |wlog| instructions should be
  10492. removed from production versions of \MF.
  10493. @p function init_screen:boolean;
  10494. begin init_screen:=false;
  10495. procedure update_screen; {will be called only if |init_screen| returns |true|}
  10496. begin @!init wlog_ln('Calling UPDATESCREEN');@+tini {for testing only}
  10497. @ The user's screen is assumed to be a rectangular area, |screen_width|
  10498. pixels wide and |screen_depth| pixels deep. The pixel in the upper left
  10499. corner is said to be in column~0 of row~0; the pixel in the lower right
  10500. corner is said to be in column |screen_width-1| of row |screen_depth-1|.
  10501. Notice that row numbers increase from top to bottom, contrary to \MF's
  10502. other coordinates.
  10503. Each pixel is assumed to have two states, referred to in this documentation
  10504. as |black| and |white|. The background color is called |white| and the
  10505. other color is called |black|; but any two distinct pixel values
  10506. can actually be used. For example, the author developed \MF\ on a
  10507. system for which |white| was black and |black| was bright green.
  10508. @d white=0 {background pixels}
  10509. @d black=1 {visible pixels}
  10510. @<Types...@>=
  10511. @!screen_row=0..screen_depth; {a row number on the screen}
  10512. @!screen_col=0..screen_width; {a column number on the screen}
  10513. @!trans_spec=array[screen_col] of screen_col; {a transition spec, see below}
  10514. @!pixel_color=white..black; {specifies one of the two pixel values}
  10515. @ We'll illustrate the |blank_rectangle| and |paint_row| operations by
  10516. pretending to declare a screen buffer called |screen_pixel|. This code
  10517. is actually commented out, but it does specify the intended effects.
  10518. @<Glob...@>=
  10519. @{@!screen_pixel:array[screen_row,screen_col] of pixel_color;@+@}
  10520. @ The |blank_rectangle| routine simply whitens all pixels that lie in
  10521. columns |left_col| through |right_col-1|, inclusive, of rows
  10522. |top_row| through |bot_row-1|, inclusive, given four parameters that satisfy
  10523. the relations
  10524. $$\hbox{|0<=left_col<=right_col<=screen_width|,\quad
  10525.   |0<=top_row<=bot_row<=screen_depth|.}$$
  10526. If |left_col=right_col| or |top_row=bot_row|, nothing happens.
  10527. The commented-out code in the following procedure is for illustrative
  10528. purposes only.
  10529. @^system dependencies@>
  10530. @p procedure blank_rectangle(@!left_col,@!right_col:screen_col;
  10531.   @!top_row,@!bot_row:screen_row);
  10532. var @!r:screen_row;
  10533. @!c:screen_col;
  10534. begin @{@+for r:=top_row to bot_row-1 do
  10535.   for c:=left_col to right_col-1 do
  10536.     screen_pixel[r,c]:=white;@+@}@/
  10537. @!init wlog_cr; {this will be done only after |init_screen=true|}
  10538. wlog_ln('Calling BLANKRECTANGLE(',left_col:1,',',
  10539.   right_col:1,',',top_row:1,',',bot_row:1,')');@+tini
  10540. @ The real work of screen display is done by |paint_row|. But it's not
  10541. hard work, because the operation affects only
  10542. one of the screen rows, and it affects only a contiguous set of columns
  10543. in that row. There are four parameters: |r|~(the row),
  10544. |b|~(the initial color),
  10545. |a|~(the array of transition specifications),
  10546. and |n|~(the number of transitions). The elements of~|a| will satisfy
  10547. $$0\L a[0]<a[1]<\cdots<a[n]\L |screen_width|;$$
  10548. the value of |r| will satisfy |0<=r<screen_depth|; and |n| will be positive.
  10549. The general idea is to paint blocks of pixels in alternate colors;
  10550. the precise details are best conveyed by means of a \PASCAL\
  10551. program (see the commented-out code below).
  10552. @^system dependencies@>
  10553. @p procedure paint_row(@!r:screen_row;@!b:pixel_color;var @!a:trans_spec;
  10554.   @!n:screen_col);
  10555. var @!k:screen_col; {an index into |a|}
  10556. @!c:screen_col; {an index into |screen_pixel|}
  10557. begin @{ k:=0; c:=a[0];
  10558. repeat incr(k);
  10559.   repeat screen_pixel[r,c]:=b; incr(c);
  10560.   until c=a[k];
  10561.   b:=black-b; {$|black|\swap|white|$}
  10562.   until k=n;@+@}@/
  10563. @!init wlog('Calling PAINTROW(',r:1,',',b:1,';');
  10564.   {this is done only after |init_screen=true|}
  10565. for k:=0 to n do
  10566.   begin wlog(a[k]:1); if k<>n then wlog(',');
  10567.   end;
  10568. wlog_ln(')');@+tini
  10569. @ The remainder of \MF's screen routines are system-independent calls
  10570. on the four primitives just defined.
  10571. First we have a global boolean variable that tells if |init_screen|
  10572. has been called, and another one that tells if |init_screen| has
  10573. given a |true| response.
  10574. @<Glob...@>=
  10575. @!screen_started:boolean; {have the screen primitives been initialized?}
  10576. @!screen_OK:boolean; {is it legitimate to call |blank_rectangle|,
  10577.   |paint_row|, and |update_screen|?}
  10578. @ @d start_screen==begin if not screen_started then
  10579.     begin screen_OK:=init_screen; screen_started:=true;
  10580.     end;
  10581.   end
  10582. @<Set init...@>=
  10583. screen_started:=false; screen_OK:=false;
  10584. @ \MF\ provides the user with 16 ``window'' areas on the screen, in each
  10585. of which it is possible to produce independent displays.
  10586. It should be noted that \MF's windows aren't really independent
  10587. ``clickable'' entities in the sense of multi-window graphic workstations;
  10588. \MF\ simply maps them into subsets of a single screen image that is
  10589. controlled by |init_screen|, |blank_rectangle|, |paint_row|, and
  10590. |update_screen| as described above. Implementations of \MF\ on a
  10591. multi-window workstation probably therefore make use of only two
  10592. windows in the other sense: one for the terminal output and another
  10593. for the screen with \MF's 16 areas. Henceforth we shall
  10594. use the term window only in \MF's sense.
  10595. @<Types...@>=
  10596. @!window_number=0..15;
  10597. @ A user doesn't have to use any of the 16 windows. But when a window is
  10598. ``opened,'' it is allocated to a specific rectangular portion of the screen
  10599. and to a specific rectangle with respect to \MF's coordinates. The relevant
  10600. data is stored in global arrays |window_open|, |left_col|, |right_col|,
  10601. |top_row|, |bot_row|, |m_window|, and |n_window|.
  10602. The |window_open| array is boolean, and its significance is obvious. The
  10603. |left_col|, \dots, |bot_row| arrays contain screen coordinates that
  10604. can be used to blank the entire window with |blank_rectangle|. And the
  10605. other two arrays just mentioned handle the conversion between
  10606. actual coordinates and screen coordinates: \MF's pixel in column~$m$
  10607. of row~$n$ will appear in screen column |m_window+m| and in screen row
  10608. |n_window-n|, provided that these lie inside the boundaries of the window.
  10609. Another array |window_time| holds the number of times this window has
  10610. been updated.
  10611. @<Glob...@>=
  10612. @!window_open:array[window_number] of boolean;
  10613.   {has this window been opened?}
  10614. @!left_col:array[window_number] of screen_col;
  10615.   {leftmost column position on screen}
  10616. @!right_col:array[window_number] of screen_col;
  10617.   {rightmost column position, plus~1}
  10618. @!top_row:array[window_number] of screen_row;
  10619.   {topmost row position on screen}
  10620. @!bot_row:array[window_number] of screen_row;
  10621.   {bottommost row position, plus~1}
  10622. @!m_window:array[window_number] of integer;
  10623.   {offset between user and screen columns}
  10624. @!n_window:array[window_number] of integer;
  10625.   {offset between user and screen rows}
  10626. @!window_time:array[window_number] of integer;
  10627.   {it has been updated this often}
  10628. @ @<Set init...@>=
  10629. for k:=0 to 15 do
  10630.   begin window_open[k]:=false; window_time[k]:=0;
  10631.   end;
  10632. @ Opening a window isn't like opening a file, because you can open it
  10633. as often as you like, and you never have to close it again. The idea is
  10634. simply to define special points on the current screen display.
  10635. Overlapping window specifications may cause complex effects that can
  10636. be understood only by scrutinizing \MF's display algorithms; thus it
  10637. has been left undefined in the \MF\ user manual, although the behavior
  10638. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  10639. is in fact predictable.
  10640. Here is a subroutine that implements the command `\&{openwindow}~|k|
  10641. \&{from}~$(\\{r0},\\{c0})$ \&{to}~$(\\{r1},\\{c1})$ \&{at}~$(x,y)$'.
  10642. @p procedure open_a_window(@!k:window_number;@!r0,@!c0,@!r1,@!c1:scaled;
  10643.     @!x,@!y:scaled);
  10644. var @!m,@!n:integer; {pixel coordinates}
  10645. begin @<Adjust the coordinates |(r0,c0)| and |(r1,c1)| so that
  10646.   they lie in the proper range@>;
  10647. window_open[k]:=true; incr(window_time[k]);@/
  10648. left_col[k]:=c0; right_col[k]:=c1; top_row[k]:=r0; bot_row[k]:=r1;@/
  10649. @<Compute the offsets between screen coordinates and actual coordinates@>;
  10650. start_screen;
  10651. if screen_OK then
  10652.   begin blank_rectangle(c0,c1,r0,r1); update_screen;
  10653.   end;
  10654. @ A window whose coordinates don't fit the existing screen size will be
  10655. truncated until they do.
  10656. @<Adjust the coordinates |(r0,c0)| and |(r1,c1)|...@>=
  10657. if r0<0 then r0:=0@+else r0:=round_unscaled(r0);
  10658. r1:=round_unscaled(r1);
  10659. if r1>screen_depth then r1:=screen_depth;
  10660. if r1<r0 then
  10661.   if r0>screen_depth then r0:=r1@+else r1:=r0;
  10662. if c0<0 then c0:=0@+else c0:=round_unscaled(c0);
  10663. c1:=round_unscaled(c1);
  10664. if c1>screen_width then c1:=screen_width;
  10665. if c1<c0 then
  10666.   if c0>screen_width then c0:=c1@+else c1:=c0
  10667. @ Three sets of coordinates are rampant, and they must be kept straight!
  10668. (i)~\MF's main coordinates refer to the edges between pixels. (ii)~\MF's
  10669. pixel coordinates (within edge structures) say that the pixel bounded by
  10670. $(m,n)$, $(m,n+1)$, $(m+1,n)$, and~$(m+1,n+1)$ is in pixel row number~$n$
  10671. and pixel column number~$m$. (iii)~Screen coordinates, on the other hand,
  10672. have rows numbered in increasing order from top to bottom, as mentioned
  10673. above.
  10674. @^coordinates, explained@>
  10675. The program here first computes integers $m$ and $n$ such that
  10676. pixel column~$m$ of pixel row~$n$ will be at the upper left corner
  10677. of the window. Hence pixel column |m-c0| of pixel row |n+r0|
  10678. will be at the upper left corner of the screen.
  10679. @<Compute the offsets between screen coordinates and actual coordinates@>=
  10680. m:=round_unscaled(x); n:=round_unscaled(y)-1;@/
  10681. m_window[k]:=c0-m; n_window[k]:=r0+n
  10682. @ Now here comes \MF's most complicated operation related to window
  10683. display: Given the number~|k| of an open window, the pixels of positive
  10684. weight in |cur_edges| will be shown as |black| in the window; all other
  10685. pixels will be shown as |white|.
  10686. @p procedure disp_edges(@!k:window_number);
  10687. label done,found;
  10688. var @!p,@!q:pointer; {for list manipulation}
  10689. @!already_there:boolean; {is a previous incarnation in the window?}
  10690. @!r:integer; {row number}
  10691. @<Other local variables for |disp_edges|@>@;
  10692. begin if screen_OK then
  10693.  if left_col[k]<right_col[k] then if top_row[k]<bot_row[k] then
  10694.   begin already_there:=false;
  10695.   if last_window(cur_edges)=k then
  10696.    if last_window_time(cur_edges)=window_time[k] then
  10697.     already_there:=true;
  10698.   if not already_there then
  10699.     blank_rectangle(left_col[k],right_col[k],top_row[k],bot_row[k]);
  10700.   @<Initialize for the display computations@>;
  10701.   p:=link(cur_edges); r:=n_window[k]-(n_min(cur_edges)-zero_field);
  10702.   while (p<>cur_edges)and(r>=top_row[k]) do
  10703.     begin if r<bot_row[k] then
  10704.       @<Display the pixels of edge row |p| in screen row |r|@>;
  10705.     p:=link(p); decr(r);
  10706.     end;
  10707.   update_screen;
  10708.   incr(window_time[k]);
  10709.   last_window(cur_edges):=k; last_window_time(cur_edges):=window_time[k];
  10710.   end;
  10711. @ Since it takes some work to display a row, we try to avoid recomputation
  10712. whenever we can.
  10713. @<Display the pixels of edge row |p| in screen row |r|@>=
  10714. begin if unsorted(p)>void then sort_edges(p)
  10715. else if unsorted(p)=void then if already_there then goto done;
  10716. unsorted(p):=void; {this time we'll paint, but maybe not next time}
  10717. @<Set up the parameters needed for |paint_row|;
  10718.   but |goto done| if no painting is needed after all@>;
  10719. paint_row(r,b,row_transition,n);
  10720. done: end
  10721. @ The transition-specification parameter to |paint_row| is always the same
  10722. array.
  10723. @<Glob...@>=
  10724. @!row_transition:trans_spec; {an array of |black|/|white| transitions}
  10725. @ The job remaining is to go through the list |sorted(p)|, unpacking the
  10726. |info| fields into |m| and weight, then making |black| the pixels whose
  10727. accumulated weight~|w| is positive.
  10728. @<Other local variables for |disp_edges|@>=
  10729. @!n:screen_col; {the highest active index in |row_transition|}
  10730. @!w,@!ww:integer; {old and new accumulated weights}
  10731. @!b:pixel_color; {status of first pixel in the row transitions}
  10732. @!m,@!mm:integer; {old and new screen column positions}
  10733. @!d:integer; {edge-and-weight without |min_halfword| compensation}
  10734. @!m_adjustment:integer; {conversion between edge and screen coordinates}
  10735. @!right_edge:integer; {largest edge-and-weight that could affect the window}
  10736. @!min_col:screen_col; {the smallest screen column number in the window}
  10737. @ Some precomputed constants make the display calculations faster.
  10738. @<Initialize for the display computations@>=
  10739. m_adjustment:=m_window[k]-m_offset(cur_edges);@/
  10740. right_edge:=8*(right_col[k]-m_adjustment);@/
  10741. min_col:=left_col[k]
  10742. @ @<Set up the parameters needed for |paint_row|...@>=
  10743. n:=0; ww:=0; m:=-1; w:=0;
  10744. q:=sorted(p); row_transition[0]:=min_col;
  10745. loop@+  begin if q=sentinel then d:=right_edge
  10746.   else d:=ho(info(q));
  10747.   mm:=(d div 8)+m_adjustment;
  10748.   if mm<>m then
  10749.     begin @<Record a possible transition in column |m|@>;
  10750.     m:=mm; w:=ww;
  10751.     end;
  10752.   if d>=right_edge then goto found;
  10753.   ww:=ww+(d mod 8)-zero_w;
  10754.   q:=link(q);
  10755.   end;
  10756. found:@<Wind up the |paint_row| parameter calculation by inserting the
  10757.   final transition; |goto done| if no painting is needed@>;
  10758. @ Now |m| is a screen column |<right_col[k]|.
  10759. @<Record a possible transition in column |m|@>=
  10760. if w<=0 then
  10761.   begin if ww>0 then if m>min_col then
  10762.     begin if n=0 then
  10763.       if already_there then
  10764.         begin b:=white; incr(n);
  10765.         end
  10766.       else b:=black
  10767.     else incr(n);
  10768.     row_transition[n]:=m;
  10769.     end;
  10770.   end
  10771. else if ww<=0 then if m>min_col then
  10772.   begin if n=0 then b:=black;
  10773.   incr(n); row_transition[n]:=m;
  10774.   end
  10775. @ If the entire row is |white| in the window area, we can omit painting it
  10776. when |already_there| is false, since it has already been blanked out in
  10777. that case.
  10778. When the following code is invoked, |row_transition[n]| will be
  10779. strictly less than |right_col[k]|.
  10780. @<Wind up the |paint_row|...@>=
  10781. if already_there or(ww>0) then
  10782.   begin if n=0 then
  10783.     if ww>0 then b:=black
  10784.     else b:=white;
  10785.   incr(n); row_transition[n]:=right_col[k];
  10786.   end
  10787. else if n=0 then goto done
  10788. @* \[28] Dynamic linear equations.
  10789. \MF\ users define variables implicitly by stating equations that should be
  10790. satisfied; the computer is supposed to be smart enough to solve those equations.
  10791. And indeed, the computer tries valiantly to do so, by distinguishing five
  10792. different types of numeric values:
  10793. \smallskip\hang
  10794. |type(p)=known| is the nice case, when |value(p)| is the |scaled| value
  10795. of the variable whose address is~|p|.
  10796. \smallskip\hang
  10797. |type(p)=dependent| means that |value(p)| is not present, but |dep_list(p)|
  10798. points to a {\sl dependency list\/} that expresses the value of variable~|p|
  10799. as a |scaled| number plus a sum of independent variables with |fraction|
  10800. coefficients.
  10801. \smallskip\hang
  10802. |type(p)=independent| means that |value(p)=64s+m|, where |s>0| is a ``serial
  10803. number'' reflecting the time this variable was first used in an equation;
  10804. also |0<=m<64|, and each dependent variable
  10805. that refers to this one is actually referring to the future value of
  10806. this variable times~$2^m$. (Usually |m=0|, but higher degrees of
  10807. scaling are sometimes needed to keep the coefficients in dependency lists
  10808. from getting too large. The value of~|m| will always be even.)
  10809. \smallskip\hang
  10810. |type(p)=numeric_type| means that variable |p| hasn't appeared in an
  10811. equation before, but it has been explicitly declared to be numeric.
  10812. \smallskip\hang
  10813. |type(p)=undefined| means that variable |p| hasn't appeared before.
  10814. \smallskip\noindent
  10815. We have actually discussed these five types in the reverse order of their
  10816. history during a computation: Once |known|, a variable never again
  10817. becomes |dependent|; once |dependent|, it almost never again becomes
  10818. |independent|; once |independent|, it never again becomes |numeric_type|;
  10819. and once |numeric_type|, it never again becomes |undefined| (except
  10820. of course when the user specifically decides to scrap the old value
  10821. and start again). A backward step may, however, take place: Sometimes
  10822. a |dependent| variable becomes |independent| again, when one of the
  10823. independent variables it depends on is reverting to |undefined|.
  10824. @d s_scale=64 {the serial numbers are multiplied by this factor}
  10825. @d new_indep(#)== {create a new independent variable}
  10826.   begin type(#):=independent; serial_no:=serial_no+s_scale;
  10827.   value(#):=serial_no;
  10828.   end
  10829. @<Glob...@>=
  10830. @!serial_no:integer; {the most recent serial number, times |s_scale|}
  10831. @ @<Make variable |q+s| newly independent@>=new_indep(q+s)
  10832. @ But how are dependency lists represented? It's simple: The linear combination
  10833. $\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If
  10834. |q=dep_list(p)| points to this list, and if |k>0|, then |value(q)=
  10835. @t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location
  10836. of $v_1$; and |link(p)| points to the dependency list
  10837. $\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|,
  10838. then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|.
  10839. The independent variables $v_1$, \dots,~$v_k$ have been sorted so that
  10840. they appear in decreasing order of their |value| fields (i.e., of
  10841. their serial numbers). \ (It is convenient to use decreasing order,
  10842. since |value(null)=0|. If the independent variables were not sorted by
  10843. serial number but by some other criterion, such as their location in |mem|,
  10844. the equation-solving mechanism would be too system-dependent, because
  10845. the ordering can affect the computed results.)
  10846. The |link| field in the node that contains the constant term $\beta$ is
  10847. called the {\sl final link\/} of the dependency list. \MF\ maintains
  10848. a doubly-linked master list of all dependency lists, in terms of a permanently
  10849. allocated node
  10850. in |mem| called |dep_head|. If there are no dependencies, we have
  10851. |link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|;
  10852. otherwise |link(dep_head)| points to the first dependent variable, say~|p|,
  10853. and |prev_dep(p)=dep_head|. We have |type(p)=dependent|, and |dep_list(p)|
  10854. points to its dependency list. If the final link of that dependency list
  10855. occurs in location~|q|, then |link(q)| points to the next dependent
  10856. variable (say~|r|); and we have |prev_dep(r)=q|, etc.
  10857. @d dep_list(#)==link(value_loc(#))
  10858.   {half of the |value| field in a |dependent| variable}
  10859. @d prev_dep(#)==info(value_loc(#))
  10860.   {the other half; makes a doubly linked list}
  10861. @d dep_node_size=2 {the number of words per dependency node}
  10862. @<Initialize table entries...@>= serial_no:=0;
  10863. link(dep_head):=dep_head; prev_dep(dep_head):=dep_head;
  10864. info(dep_head):=null; dep_list(dep_head):=null;
  10865. @ Actually the description above contains a little white lie. There's
  10866. another kind of variable called |proto_dependent|, which is
  10867. just like a |dependent| one except that the $\alpha$ coefficients
  10868. in its dependency list are |scaled| instead of being fractions.
  10869. Proto-dependency lists are mixed with dependency lists in the
  10870. nodes reachable from |dep_head|.
  10871. @ Here is a procedure that prints a dependency list in symbolic form.
  10872. The second parameter should be either |dependent| or |proto_dependent|,
  10873. to indicate the scaling of the coefficients.
  10874. @<Declare subroutines for printing expressions@>=
  10875. procedure print_dependency(@!p:pointer;@!t:small_number);
  10876. label exit;
  10877. var @!v:integer; {a coefficient}
  10878. @!pp,@!q:pointer; {for list manipulation}
  10879. begin pp:=p;
  10880. loop@+  begin v:=abs(value(p)); q:=info(p);
  10881.   if q=null then {the constant term}
  10882.     begin if (v<>0)or(p=pp) then
  10883.       begin if value(p)>0 then if p<>pp then print_char("+");
  10884.       print_scaled(value(p));
  10885.       end;
  10886.     return;
  10887.     end;
  10888.   @<Print the coefficient, unless it's $\pm1.0$@>;
  10889.   if type(q)<>independent then confusion("dep");
  10890. @:this can't happen dep}{\quad dep@>
  10891.   print_variable_name(q); v:=value(q) mod s_scale;
  10892.   while v>0 do
  10893.     begin print("*4"); v:=v-2;
  10894.     end;
  10895.   p:=link(p);
  10896.   end;
  10897. exit:end;
  10898. @ @<Print the coefficient, unless it's $\pm1.0$@>=
  10899. if value(p)<0 then print_char("-")
  10900. else if p<>pp then print_char("+");
  10901. if t=dependent then v:=round_fraction(v);
  10902. if v<>unity then print_scaled(v)
  10903. @ The maximum absolute value of a coefficient in a given dependency list
  10904. is returned by the following simple function.
  10905. @p function max_coef(@!p:pointer):fraction;
  10906. var @!x:fraction; {the maximum so far}
  10907. begin x:=0;
  10908. while info(p)<>null do
  10909.   begin if abs(value(p))>x then x:=abs(value(p));
  10910.   p:=link(p);
  10911.   end;
  10912. max_coef:=x;
  10913. @ One of the main operations needed on dependency lists is to add a multiple
  10914. of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point
  10915. to dependency lists and |f| is a fraction.
  10916. If the coefficient of any independent variable becomes |coef_bound| or
  10917. more, in absolute value, this procedure changes the type of that variable
  10918. to `|independent_needing_fix|', and sets the global variable |fix_needed|
  10919. to~|true|. The value of $|coef_bound|=\mu$ is chosen so that
  10920. $\mu^2+\mu<8$; this means that the numbers we deal with won't
  10921. get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx
  10922. 2.3723$, the safer value 7/3 is taken as the threshold.)
  10923. The changes mentioned in the preceding paragraph are actually done only if
  10924. the global variable |watch_coefs| is |true|. But it usually is; in fact,
  10925. it is |false| only when \MF\ is making a dependency list that will soon
  10926. be equated to zero.
  10927. Several procedures that act on dependency lists, including |p_plus_fq|,
  10928. set the global variable |dep_final| to the final (constant term) node of
  10929. the dependency list that they produce.
  10930. @d coef_bound==@'4525252525 {|fraction| approximation to 7/3}
  10931. @d independent_needing_fix=0
  10932. @<Glob...@>=
  10933. @!fix_needed:boolean; {does at least one |independent| variable need scaling?}
  10934. @!watch_coefs:boolean; {should we scale coefficients that exceed |coef_bound|?}
  10935. @!dep_final:pointer; {location of the constant term and final link}
  10936. @ @<Set init...@>=
  10937. fix_needed:=false; watch_coefs:=true;
  10938. @ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be
  10939. set to |proto_dependent| if |p| is a proto-dependency list. In this
  10940. case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt|
  10941. should be |proto_dependent| if |q| is a proto-dependency list.
  10942. List |q| is unchanged by the operation; but list |p| is totally destroyed.
  10943. The final link of the dependency list or proto-dependency list returned
  10944. by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the
  10945. constant term of the result will be located in the same |mem| location
  10946. as the original constant term of~|p|.
  10947. Coefficients of the result are assumed to be zero if they are less than
  10948. a certain threshold. This compensates for inevitable rounding errors,
  10949. and tends to make more variables `|known|'. The threshold is approximately
  10950. $10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for
  10951. proto-dependencies.
  10952. @d fraction_threshold=2685 {a |fraction| coefficient less than this is zeroed}
  10953. @d half_fraction_threshold=1342 {half of |fraction_threshold|}
  10954. @d scaled_threshold=8 {a |scaled| coefficient less than this is zeroed}
  10955. @d half_scaled_threshold=4 {half of |scaled_threshold|}
  10956. @<Declare basic dependency-list subroutines@>=
  10957. function p_plus_fq(@!p:pointer;@!f:integer;@!q:pointer;
  10958.   @!t,@!tt:small_number):pointer;
  10959. label done;
  10960. var @!pp,@!qq:pointer; {|info(p)| and |info(q)|, respectively}
  10961. @!r,@!s:pointer; {for list manipulation}
  10962. @!threshold:integer; {defines a neighborhood of zero}
  10963. @!v:integer; {temporary register}
  10964. begin if t=dependent then threshold:=fraction_threshold
  10965. else threshold:=scaled_threshold;
  10966. r:=temp_head; pp:=info(p); qq:=info(q);
  10967. loop@+  if pp=qq then
  10968.     if pp=null then goto done
  10969.     else @<Contribute a term from |p|, plus |f| times the
  10970.       corresponding term from |q|@>
  10971.   else if value(pp)<value(qq) then
  10972.     @<Contribute a term from |q|, multiplied by~|f|@>
  10973.   else  begin link(r):=p; r:=p; p:=link(p); pp:=info(p);
  10974.     end;
  10975. done: if t=dependent then
  10976.   value(p):=slow_add(value(p),take_fraction(value(q),f))
  10977. else  value(p):=slow_add(value(p),take_scaled(value(q),f));
  10978. link(r):=p; dep_final:=p; p_plus_fq:=link(temp_head);
  10979. @ @<Contribute a term from |p|, plus |f|...@>=
  10980. begin if tt=dependent then v:=value(p)+take_fraction(f,value(q))
  10981. else v:=value(p)+take_scaled(f,value(q));
  10982. value(p):=v; s:=p; p:=link(p);
  10983. if abs(v)<threshold then free_node(s,dep_node_size)
  10984. else  begin if abs(v)>=coef_bound then if watch_coefs then
  10985.     begin type(qq):=independent_needing_fix; fix_needed:=true;
  10986.     end;
  10987.   link(r):=s; r:=s;
  10988.   end;
  10989. pp:=info(p); q:=link(q); qq:=info(q);
  10990. @ @<Contribute a term from |q|, multiplied by~|f|@>=
  10991. begin if tt=dependent then v:=take_fraction(f,value(q))
  10992. else v:=take_scaled(f,value(q));
  10993. if abs(v)>half(threshold) then
  10994.   begin s:=get_node(dep_node_size); info(s):=qq; value(s):=v;
  10995.   if abs(v)>=coef_bound then if watch_coefs then
  10996.     begin type(qq):=independent_needing_fix; fix_needed:=true;
  10997.     end;
  10998.   link(r):=s; r:=s;
  10999.   end;
  11000. q:=link(q); qq:=info(q);
  11001. @ It is convenient to have another subroutine for the special case
  11002. of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are
  11003. both of the same type~|t| (either |dependent| or |proto_dependent|).
  11004. @p function p_plus_q(@!p:pointer;@!q:pointer;@!t:small_number):pointer;
  11005. label done;
  11006. var @!pp,@!qq:pointer; {|info(p)| and |info(q)|, respectively}
  11007. @!r,@!s:pointer; {for list manipulation}
  11008. @!threshold:integer; {defines a neighborhood of zero}
  11009. @!v:integer; {temporary register}
  11010. begin if t=dependent then threshold:=fraction_threshold
  11011. else threshold:=scaled_threshold;
  11012. r:=temp_head; pp:=info(p); qq:=info(q);
  11013. loop@+  if pp=qq then
  11014.     if pp=null then goto done
  11015.     else @<Contribute a term from |p|, plus the
  11016.       corresponding term from |q|@>
  11017.   else if value(pp)<value(qq) then
  11018.     begin s:=get_node(dep_node_size); info(s):=qq; value(s):=value(q);
  11019.     q:=link(q); qq:=info(q); link(r):=s; r:=s;
  11020.     end
  11021.   else  begin link(r):=p; r:=p; p:=link(p); pp:=info(p);
  11022.     end;
  11023. done: value(p):=slow_add(value(p),value(q));
  11024. link(r):=p; dep_final:=p; p_plus_q:=link(temp_head);
  11025. @ @<Contribute a term from |p|, plus the...@>=
  11026. begin v:=value(p)+value(q);
  11027. value(p):=v; s:=p; p:=link(p); pp:=info(p);
  11028. if abs(v)<threshold then free_node(s,dep_node_size)
  11029. else  begin if abs(v)>=coef_bound then if watch_coefs then
  11030.     begin type(qq):=independent_needing_fix; fix_needed:=true;
  11031.     end;
  11032.   link(r):=s; r:=s;
  11033.   end;
  11034. q:=link(q); qq:=info(q);
  11035. @ A somewhat simpler routine will multiply a dependency list
  11036. by a given constant~|v|. The constant is either a |fraction| less than
  11037. |fraction_one|, or it is |scaled|. In the latter case we might be forced to
  11038. convert a dependency list to a proto-dependency list.
  11039. Parameters |t0| and |t1| are the list types before and after;
  11040. they should agree unless |t0=dependent| and |t1=proto_dependent|
  11041. and |v_is_scaled=true|.
  11042. @p function p_times_v(@!p:pointer;@!v:integer;
  11043.   @!t0,@!t1:small_number;@!v_is_scaled:boolean):pointer;
  11044. var @!r,@!s:pointer; {for list manipulation}
  11045. @!w:integer; {tentative coefficient}
  11046. @!threshold:integer;
  11047. @!scaling_down:boolean;
  11048. begin if t0<>t1 then scaling_down:=true@+else scaling_down:=not v_is_scaled;
  11049. if t1=dependent then threshold:=half_fraction_threshold
  11050. else threshold:=half_scaled_threshold;
  11051. r:=temp_head;
  11052. while info(p)<>null do
  11053.   begin if scaling_down then w:=take_fraction(v,value(p))
  11054.   else w:=take_scaled(v,value(p));
  11055.   if abs(w)<=threshold then
  11056.     begin s:=link(p); free_node(p,dep_node_size); p:=s;
  11057.     end
  11058.   else  begin if abs(w)>=coef_bound then
  11059.       begin fix_needed:=true; type(info(p)):=independent_needing_fix;
  11060.       end;
  11061.     link(r):=p; r:=p; value(p):=w; p:=link(p);
  11062.     end;
  11063.   end;
  11064. link(r):=p;
  11065. if v_is_scaled then value(p):=take_scaled(value(p),v)
  11066. else value(p):=take_fraction(value(p),v);
  11067. p_times_v:=link(temp_head);
  11068. @ Similarly, we sometimes need to divide a dependency list
  11069. by a given |scaled| constant.
  11070. @<Declare basic dependency-list subroutines@>=
  11071. function p_over_v(@!p:pointer;@!v:scaled;
  11072.   @!t0,@!t1:small_number):pointer;
  11073. var @!r,@!s:pointer; {for list manipulation}
  11074. @!w:integer; {tentative coefficient}
  11075. @!threshold:integer;
  11076. @!scaling_down:boolean;
  11077. begin if t0<>t1 then scaling_down:=true@+else scaling_down:=false;
  11078. if t1=dependent then threshold:=half_fraction_threshold
  11079. else threshold:=half_scaled_threshold;
  11080. r:=temp_head;
  11081. while info(p)<>null do
  11082.   begin if scaling_down then
  11083.     if abs(v)<@'2000000 then w:=make_scaled(value(p),v*@'10000)
  11084.     else w:=make_scaled(round_fraction(value(p)),v)
  11085.   else w:=make_scaled(value(p),v);
  11086.   if abs(w)<=threshold then
  11087.     begin s:=link(p); free_node(p,dep_node_size); p:=s;
  11088.     end
  11089.   else  begin if abs(w)>=coef_bound then
  11090.       begin fix_needed:=true; type(info(p)):=independent_needing_fix;
  11091.       end;
  11092.     link(r):=p; r:=p; value(p):=w; p:=link(p);
  11093.     end;
  11094.   end;
  11095. link(r):=p; value(p):=make_scaled(value(p),v);
  11096. p_over_v:=link(temp_head);
  11097. @ Here's another utility routine for dependency lists. When an independent
  11098. variable becomes dependent, we want to remove it from all existing
  11099. dependencies. The |p_with_x_becoming_q| function computes the
  11100. dependency list of~|p| after variable~|x| has been replaced by~|q|.
  11101. This procedure has basically the same calling conventions as |p_plus_fq|:
  11102. List~|q| is unchanged; list~|p| is destroyed; the constant node and the
  11103. final link are inherited from~|p|; and the fourth parameter tells whether
  11104. or not |p| is |proto_dependent|. However, the global variable |dep_final|
  11105. is not altered if |x| does not occur in list~|p|.
  11106. @p function p_with_x_becoming_q(@!p,@!x,@!q:pointer;@!t:small_number):pointer;
  11107. var @!r,@!s:pointer; {for list manipulation}
  11108. @!v:integer; {coefficient of |x|}
  11109. @!sx:integer; {serial number of |x|}
  11110. begin s:=p; r:=temp_head; sx:=value(x);
  11111. while value(info(s))>sx do
  11112.   begin r:=s; s:=link(s);
  11113.   end;
  11114. if info(s)<>x then p_with_x_becoming_q:=p
  11115. else  begin link(temp_head):=p; link(r):=link(s); v:=value(s);
  11116.   free_node(s,dep_node_size);
  11117.   p_with_x_becoming_q:=p_plus_fq(link(temp_head),v,q,t,dependent);
  11118.   end;
  11119. @ Here's a simple procedure that reports an error when a variable
  11120. has just received a known value that's out of the required range.
  11121. @<Declare basic dependency-list subroutines@>=
  11122. procedure val_too_big(@!x:scaled);
  11123. begin if internal[warning_check]>0 then
  11124.   begin print_err("Value is too large ("); print_scaled(x); print_char(")");
  11125. @.Value is too large@>
  11126.   help4("The equation I just processed has given some variable")@/
  11127.     ("a value of 4096 or more. Continue and I'll try to cope")@/
  11128.     ("with that big value; but it might be dangerous.")@/
  11129.     ("(Set warningcheck:=0 to suppress this message.)");
  11130.   error;
  11131.   end;
  11132. @ When a dependent variable becomes known, the following routine
  11133. removes its dependency list. Here |p| points to the variable, and
  11134. |q| points to the dependency list (which is one node long).
  11135. @<Declare basic dependency-list subroutines@>=
  11136. procedure make_known(@!p,@!q:pointer);
  11137. var @!t:dependent..proto_dependent; {the previous type}
  11138. begin prev_dep(link(q)):=prev_dep(p);
  11139. link(prev_dep(p)):=link(q); t:=type(p);
  11140. type(p):=known; value(p):=value(q); free_node(q,dep_node_size);
  11141. if abs(value(p))>=fraction_one then val_too_big(value(p));
  11142. if internal[tracing_equations]>0 then if interesting(p) then
  11143.   begin begin_diagnostic; print_nl("#### ");
  11144. @:]]]\#\#\#\#_}{\.{\#\#\#\#}@>
  11145.   print_variable_name(p); print_char("="); print_scaled(value(p));
  11146.   end_diagnostic(false);
  11147.   end;
  11148. if cur_exp=p then if cur_type=t then
  11149.   begin cur_type:=known; cur_exp:=value(p);
  11150.   free_node(p,value_node_size);
  11151.   end;
  11152. @ The |fix_dependencies| routine is called into action when |fix_needed|
  11153. has been triggered. The program keeps a list~|s| of independent variables
  11154. whose coefficients must be divided by~4.
  11155. In unusual cases, this fixup process might reduce one or more coefficients
  11156. to zero, so that a variable will become known more or less by default.
  11157. @<Declare basic dependency-list subroutines@>=
  11158. procedure fix_dependencies;
  11159. label done;
  11160. var @!p,@!q,@!r,@!s,@!t:pointer; {list manipulation registers}
  11161. @!x:pointer; {an independent variable}
  11162. begin r:=link(dep_head); s:=null;
  11163. while r<>dep_head do
  11164.   begin t:=r;
  11165.   @<Run through the dependency list for variable |t|, fixing
  11166.     all nodes, and ending with final link~|q|@>;
  11167.   r:=link(q);
  11168.   if q=dep_list(t) then make_known(t,q);
  11169.   end;
  11170. while s<>null do
  11171.   begin p:=link(s); x:=info(s); free_avail(s); s:=p;
  11172.   type(x):=independent; value(x):=value(x)+2;
  11173.   end;
  11174. fix_needed:=false;
  11175. @ @d independent_being_fixed=1 {this variable already appears in |s|}
  11176. @<Run through the dependency list for variable |t|...@>=
  11177. r:=value_loc(t); {|link(r)=dep_list(t)|}
  11178. loop@+  begin q:=link(r); x:=info(q);
  11179.   if x=null then goto done;
  11180.   if type(x)<=independent_being_fixed then
  11181.     begin if type(x)<independent_being_fixed then
  11182.       begin p:=get_avail; link(p):=s; s:=p;
  11183.       info(s):=x; type(x):=independent_being_fixed;
  11184.       end;
  11185.     value(q):=value(q) div 4;
  11186.     if value(q)=0 then
  11187.       begin link(r):=link(q); free_node(q,dep_node_size); q:=r;
  11188.       end;
  11189.     end;
  11190.   r:=q;
  11191.   end;
  11192. done:
  11193. @ The |new_dep| routine installs a dependency list~|p| into the value node~|q|,
  11194. linking it into the list of all known dependencies. We assume that
  11195. |dep_final| points to the final node of list~|p|.
  11196. @p procedure new_dep(@!q,@!p:pointer);
  11197. var @!r:pointer; {what used to be the first dependency}
  11198. begin dep_list(q):=p; prev_dep(q):=dep_head;
  11199. r:=link(dep_head); link(dep_final):=r; prev_dep(r):=dep_final;
  11200. link(dep_head):=q;
  11201. @ Here is one of the ways a dependency list gets started.
  11202. The |const_dependency| routine produces a list that has nothing but
  11203. a constant term.
  11204. @p function const_dependency(@!v:scaled):pointer;
  11205. begin dep_final:=get_node(dep_node_size);
  11206. value(dep_final):=v; info(dep_final):=null;
  11207. const_dependency:=dep_final;
  11208. @ And here's a more interesting way to start a dependency list from scratch:
  11209. The parameter to |single_dependency| is the location of an
  11210. independent variable~|x|, and the result is the simple dependency list
  11211. `|x+0|'.
  11212. In the unlikely event that the given independent variable has been doubled so
  11213. often that we can't refer to it with a nonzero coefficient,
  11214. |single_dependency| returns the simple list `0'.  This case can be
  11215. recognized by testing that the returned list pointer is equal to
  11216. |dep_final|.
  11217. @p function single_dependency(@!p:pointer):pointer;
  11218. var @!q:pointer; {the new dependency list}
  11219. @!m:integer; {the number of doublings}
  11220. begin m:=value(p) mod s_scale;
  11221. if m>28 then single_dependency:=const_dependency(0)
  11222. else  begin q:=get_node(dep_node_size);
  11223.   value(q):=two_to_the[28-m]; info(q):=p;@/
  11224.   link(q):=const_dependency(0); single_dependency:=q;
  11225.   end;
  11226. @ We sometimes need to make an exact copy of a dependency list.
  11227. @p function copy_dep_list(@!p:pointer):pointer;
  11228. label done;
  11229. var @!q:pointer; {the new dependency list}
  11230. begin q:=get_node(dep_node_size); dep_final:=q;
  11231. loop@+  begin info(dep_final):=info(p); value(dep_final):=value(p);
  11232.   if info(dep_final)=null then goto done;
  11233.   link(dep_final):=get_node(dep_node_size);
  11234.   dep_final:=link(dep_final); p:=link(p);
  11235.   end;
  11236. done:copy_dep_list:=q;
  11237. @ But how do variables normally become known? Ah, now we get to the heart of the
  11238. equation-solving mechanism. The |linear_eq| procedure is given a |dependent|
  11239. or |proto_dependent| list,~|p|, in which at least one independent variable
  11240. appears. It equates this list to zero, by choosing an independent variable
  11241. with the largest coefficient and making it dependent on the others. The
  11242. newly dependent variable is eliminated from all current dependencies,
  11243. thereby possibly making other dependent variables known.
  11244. The given list |p| is, of course, totally destroyed by all this processing.
  11245. @p procedure linear_eq(@!p:pointer;@!t:small_number);
  11246. var @!q,@!r,@!s:pointer; {for link manipulation}
  11247. @!x:pointer; {the variable that loses its independence}
  11248. @!n:integer; {the number of times |x| had been halved}
  11249. @!v:integer; {the coefficient of |x| in list |p|}
  11250. @!prev_r:pointer; {lags one step behind |r|}
  11251. @!final_node:pointer; {the constant term of the new dependency list}
  11252. @!w:integer; {a tentative coefficient}
  11253. begin @<Find a node |q| in list |p| whose coefficient |v| is largest@>;
  11254. x:=info(q); n:=value(x) mod s_scale;@/
  11255. @<Divide list |p| by |-v|, removing node |q|@>;
  11256. if internal[tracing_equations]>0 then @<Display the new dependency@>;
  11257. @<Simplify all existing dependencies by substituting for |x|@>;
  11258. @<Change variable |x| from |independent| to |dependent| or |known|@>;
  11259. if fix_needed then fix_dependencies;
  11260. @ @<Find a node |q| in list |p| whose coefficient |v| is largest@>=
  11261. q:=p; r:=link(p); v:=value(q);
  11262. while info(r)<>null do
  11263.   begin if abs(value(r))>abs(v) then
  11264.     begin q:=r; v:=value(r);
  11265.     end;
  11266.   r:=link(r);
  11267.   end
  11268. @ Here we want to change the coefficients from |scaled| to |fraction|,
  11269. except in the constant term. In the common case of a trivial equation
  11270. like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=dependent|.
  11271. @<Divide list |p| by |-v|, removing node |q|@>=
  11272. s:=temp_head; link(s):=p; r:=p;
  11273. repeat if r=q then
  11274.   begin link(s):=link(r); free_node(r,dep_node_size);
  11275.   end
  11276. else  begin w:=make_fraction(value(r),v);
  11277.   if abs(w)<=half_fraction_threshold then
  11278.     begin link(s):=link(r); free_node(r,dep_node_size);
  11279.     end
  11280.   else  begin value(r):=-w; s:=r;
  11281.     end;
  11282.   end;
  11283. r:=link(s);
  11284. until info(r)=null;
  11285. if t=proto_dependent then value(r):=-make_scaled(value(r),v)
  11286. else if v<>-fraction_one then value(r):=-make_fraction(value(r),v);
  11287. final_node:=r; p:=link(temp_head)
  11288. @ @<Display the new dependency@>=
  11289. if interesting(x) then
  11290.   begin begin_diagnostic; print_nl("## "); print_variable_name(x);
  11291. @:]]]\#\#_}{\.{\#\#}@>
  11292.   w:=n;
  11293.   while w>0 do
  11294.     begin print("*4"); w:=w-2;
  11295.     end;
  11296.   print_char("="); print_dependency(p,dependent); end_diagnostic(false);
  11297.   end
  11298. @ @<Simplify all existing dependencies by substituting for |x|@>=
  11299. prev_r:=dep_head; r:=link(dep_head);
  11300. while r<>dep_head do
  11301.   begin s:=dep_list(r); q:=p_with_x_becoming_q(s,x,p,type(r));
  11302.   if info(q)=null then make_known(r,q)
  11303.   else  begin dep_list(r):=q;
  11304.     repeat q:=link(q);
  11305.     until info(q)=null;
  11306.     prev_r:=q;
  11307.     end;
  11308.   r:=link(prev_r);
  11309.   end
  11310. @ @<Change variable |x| from |independent| to |dependent| or |known|@>=
  11311. if n>0 then @<Divide list |p| by $2^n$@>;
  11312. if info(p)=null then
  11313.   begin type(x):=known;
  11314.   value(x):=value(p);
  11315.   if abs(value(x))>=fraction_one then val_too_big(value(x));
  11316.   free_node(p,dep_node_size);
  11317.   if cur_exp=x then if cur_type=independent then
  11318.     begin cur_exp:=value(x); cur_type:=known;
  11319.     free_node(x,value_node_size);
  11320.     end;
  11321.   end
  11322. else  begin type(x):=dependent; dep_final:=final_node; new_dep(x,p);
  11323.   if cur_exp=x then if cur_type=independent then cur_type:=dependent;
  11324.   end
  11325. @ @<Divide list |p| by $2^n$@>=
  11326. begin s:=temp_head; link(temp_head):=p; r:=p;
  11327. repeat if n>30 then w:=0
  11328. else w:=value(r) div two_to_the[n];
  11329. if (abs(w)<=half_fraction_threshold)and(info(r)<>null) then
  11330.   begin link(s):=link(r);
  11331.   free_node(r,dep_node_size);
  11332.   end
  11333. else  begin value(r):=w; s:=r;
  11334.   end;
  11335. r:=link(s);
  11336. until info(s)=null;
  11337. p:=link(temp_head);
  11338. @ The |check_mem| procedure, which is used only when \MF\ is being
  11339. debugged, makes sure that the current dependency lists are well formed.
  11340. @<Check the list of linear dependencies@>=
  11341. q:=dep_head; p:=link(q);
  11342. while p<>dep_head do
  11343.   begin if prev_dep(p)<>q then
  11344.     begin print_nl("Bad PREVDEP at "); print_int(p);
  11345. @.Bad PREVDEP...@>
  11346.     end;
  11347.   p:=dep_list(p); r:=inf_val;
  11348.   repeat if value(info(p))>=value(r) then
  11349.     begin print_nl("Out of order at "); print_int(p);
  11350. @.Out of order...@>
  11351.     end;
  11352.   r:=info(p); q:=p; p:=link(q);
  11353.   until r=null;
  11354.   end
  11355. @* \[29] Dynamic nonlinear equations.
  11356. Variables of numeric type are maintained by the general scheme of
  11357. independent, dependent, and known values that we have just studied;
  11358. and the components of pair and transform variables are handled in the
  11359. same way. But \MF\ also has five other types of values: \&{boolean},
  11360. \&{string}, \&{pen}, \&{path}, and \&{picture}; what about them?
  11361. Equations are allowed between nonlinear quantities, but only in a
  11362. simple form. Two variables that haven't yet been assigned values are
  11363. either equal to each other, or they're not.
  11364. Before a boolean variable has received a value, its type is |unknown_boolean|;
  11365. similarly, there are variables whose type is |unknown_string|, |unknown_pen|,
  11366. |unknown_path|, and |unknown_picture|. In such cases the value is either
  11367. |null| (which means that no other variables are equivalent to this one), or
  11368. it points to another variable of the same undefined type. The pointers in the
  11369. latter case form a cycle of nodes, which we shall call a ``ring.''
  11370. Rings of undefined variables may include capsules, which arise as
  11371. intermediate results within expressions or as \&{expr} parameters to macros.
  11372. When one member of a ring receives a value, the same value is given to
  11373. all the other members. In the case of paths and pictures, this implies
  11374. making separate copies of a potentially large data structure; users should
  11375. restrain their enthusiasm for such generality, unless they have lots and
  11376. lots of memory space.
  11377. @ The following procedure is called when a capsule node is being
  11378. added to a ring (e.g., when an unknown variable is mentioned in an expression).
  11379. @p function new_ring_entry(@!p:pointer):pointer;
  11380. var q:pointer; {the new capsule node}
  11381. begin q:=get_node(value_node_size); name_type(q):=capsule;
  11382. type(q):=type(p);
  11383. if value(p)=null then value(q):=p@+else value(q):=value(p);
  11384. value(p):=q;
  11385. new_ring_entry:=q;
  11386. @ Conversely, we might delete a capsule or a variable before it becomes known.
  11387. The following procedure simply detaches a quantity from its ring,
  11388. without recycling the storage.
  11389. @<Declare the recycling subroutines@>=
  11390. procedure ring_delete(@!p:pointer);
  11391. var @!q:pointer;
  11392. begin q:=value(p);
  11393. if q<>null then if q<>p then
  11394.   begin while value(q)<>p do q:=value(q);
  11395.   value(q):=value(p);
  11396.   end;
  11397. @ Eventually there might be an equation that assigns values to all of the
  11398. variables in a ring. The |nonlinear_eq| subroutine does the necessary
  11399. propagation of values.
  11400. If the parameter |flush_p| is |true|, node |p| itself needn't receive a
  11401. value; it will soon be recycled.
  11402. @p procedure nonlinear_eq(@!v:integer;@!p:pointer;@!flush_p:boolean);
  11403. var @!t:small_number; {the type of ring |p|}
  11404. @!q,@!r:pointer; {link manipulation registers}
  11405. begin t:=type(p)-unknown_tag; q:=value(p);
  11406. if flush_p then type(p):=vacuous@+else p:=q;
  11407. repeat r:=value(q); type(q):=t;
  11408. case t of
  11409. boolean_type: value(q):=v;
  11410. string_type: begin value(q):=v; add_str_ref(v);
  11411.   end;
  11412. pen_type: begin value(q):=v; add_pen_ref(v);
  11413.   end;
  11414. path_type: value(q):=copy_path(v);
  11415. picture_type: value(q):=copy_edges(v);
  11416. end; {there ain't no more cases}
  11417. q:=r;
  11418. until q=p;
  11419. @ If two members of rings are equated, and if they have the same type,
  11420. the |ring_merge| procedure is called on to make them equivalent.
  11421. @p procedure ring_merge(@!p,@!q:pointer);
  11422. label exit;
  11423. var @!r:pointer; {traverses one list}
  11424. begin r:=value(p);
  11425. while r<>p do
  11426.   begin if r=q then
  11427.     begin @<Exclaim about a redundant equation@>;
  11428.     return;
  11429.     end;
  11430.   r:=value(r);
  11431.   end;
  11432. r:=value(p); value(p):=value(q); value(q):=r;
  11433. exit:end;
  11434. @ @<Exclaim about a redundant equation@>=
  11435. begin print_err("Redundant equation");@/
  11436. @.Redundant equation@>
  11437. help2("I already knew that this equation was true.")@/
  11438.   ("But perhaps no harm has been done; let's continue.");@/
  11439. put_get_error;
  11440. @* \[30] Introduction to the syntactic routines.
  11441. Let's pause a moment now and try to look at the Big Picture.
  11442. The \MF\ program consists of three main parts: syntactic routines,
  11443. semantic routines, and output routines. The chief purpose of the
  11444. syntactic routines is to deliver the user's input to the semantic routines,
  11445. while parsing expressions and locating operators and operands. The
  11446. semantic routines act as an interpreter responding to these operators,
  11447. which may be regarded as commands. And the output routines are
  11448. periodically called on to produce compact font descriptions that can be
  11449. used for typesetting or for making interim proof drawings. We have
  11450. discussed the basic data structures and many of the details of semantic
  11451. operations, so we are good and ready to plunge into the part of \MF\ that
  11452. actually controls the activities.
  11453. Our current goal is to come to grips with the |get_next| procedure,
  11454. which is the keystone of \MF's input mechanism. Each call of |get_next|
  11455. sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|,
  11456. representing the next input token.
  11457. $$\vbox{\halign{#\hfil\cr
  11458.   \hbox{|cur_cmd| denotes a command code from the long list of codes
  11459.    given earlier;}\cr
  11460.   \hbox{|cur_mod| denotes a modifier of the command code;}\cr
  11461.   \hbox{|cur_sym| is the hash address of the symbolic token that was
  11462.    just scanned,}\cr
  11463.   \hbox{\qquad or zero in the case of a numeric or string
  11464.    or capsule token.}\cr}}$$
  11465. Underlying this external behavior of |get_next| is all the machinery
  11466. necessary to convert from character files to tokens. At a given time we
  11467. may be only partially finished with the reading of several files (for
  11468. which \&{input} was specified), and partially finished with the expansion
  11469. of some user-defined macros and/or some macro parameters, and partially
  11470. finished reading some text that the user has inserted online,
  11471. and so on. When reading a character file, the characters must be
  11472. converted to tokens; comments and blank spaces must
  11473. be removed, numeric and string tokens must be evaluated.
  11474. To handle these situations, which might all be present simultaneously,
  11475. \MF\ uses various stacks that hold information about the incomplete
  11476. activities, and there is a finite state control for each level of the
  11477. input mechanism. These stacks record the current state of an implicitly
  11478. recursive process, but the |get_next| procedure is not recursive.
  11479. @<Glob...@>=
  11480. @!cur_cmd: eight_bits; {current command set by |get_next|}
  11481. @!cur_mod: integer; {operand of current command}
  11482. @!cur_sym: halfword; {hash address of current symbol}
  11483. @ The |print_cmd_mod| routine prints a symbolic interpretation of a
  11484. command code and its modifier.
  11485. It consists of a rather tedious sequence of print
  11486. commands, and most of it is essentially an inverse to the |primitive|
  11487. routine that enters a \MF\ primitive into |hash| and |eqtb|. Therefore almost
  11488. all of this procedure appears elsewhere in the program, together with the
  11489. corresponding |primitive| calls.
  11490. @<Declare the procedure called |print_cmd_mod|@>=
  11491. procedure print_cmd_mod(@!c,@!m:integer);
  11492. begin case c of
  11493. @t\4@>@<Cases of |print_cmd_mod| for symbolic printing of primitives@>@/
  11494. othercases print("[unknown command code!]")
  11495. endcases;
  11496. @ Here is a procedure that displays a given command in braces, in the
  11497. user's transcript file.
  11498. @d show_cur_cmd_mod==show_cmd_mod(cur_cmd,cur_mod)
  11499. @p procedure show_cmd_mod(@!c,@!m:integer);
  11500. begin begin_diagnostic; print_nl("{");
  11501. print_cmd_mod(c,m); print_char("}");
  11502. end_diagnostic(false);
  11503. @* \[31] Input stacks and states.
  11504. The state of \MF's input mechanism appears in the input stack, whose
  11505. entries are records with five fields, called |index|, |start|, |loc|,
  11506. |limit|, and |name|. The top element of this stack is maintained in a
  11507. global variable for which no subscripting needs to be done; the other
  11508. elements of the stack appear in an array. Hence the stack is declared thus:
  11509. @<Types...@>=
  11510. @!in_state_record = record
  11511.   @!index_field: quarterword;
  11512.   @!start_field,@!loc_field, @!limit_field, @!name_field: halfword;
  11513.   end;
  11514. @ @<Glob...@>=
  11515. @!input_stack : array[0..stack_size] of in_state_record;
  11516. @!input_ptr : 0..stack_size; {first unused location of |input_stack|}
  11517. @!max_in_stack: 0..stack_size; {largest value of |input_ptr| when pushing}
  11518. @!cur_input : in_state_record; {the ``top'' input state}
  11519. @ We've already defined the special variable |@!loc==cur_input.loc_field|
  11520. in our discussion of basic input-output routines. The other components of
  11521. |cur_input| are defined in the same way:
  11522. @d index==cur_input.index_field {reference for buffer information}
  11523. @d start==cur_input.start_field {starting position in |buffer|}
  11524. @d limit==cur_input.limit_field {end of current line in |buffer|}
  11525. @d name==cur_input.name_field {name of the current file}
  11526. @ Let's look more closely now at the five control variables
  11527. (|index|,~|start|,~|loc|,~|limit|,~|name|),
  11528. assuming that \MF\ is reading a line of characters that have been input
  11529. from some file or from the user's terminal. There is an array called
  11530. |buffer| that acts as a stack of all lines of characters that are
  11531. currently being read from files, including all lines on subsidiary
  11532. levels of the input stack that are not yet completed. \MF\ will return to
  11533. the other lines when it is finished with the present input file.
  11534. (Incidentally, on a machine with byte-oriented addressing, it would be
  11535. appropriate to combine |buffer| with the |str_pool| array,
  11536. letting the buffer entries grow downward from the top of the string pool
  11537. and checking that these two tables don't bump into each other.)
  11538. The line we are currently working on begins in position |start| of the
  11539. buffer; the next character we are about to read is |buffer[loc]|; and
  11540. |limit| is the location of the last character present. We always have
  11541. |loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so
  11542. that the end of a line is easily sensed.
  11543. The |name| variable is a string number that designates the name of
  11544. the current file, if we are reading a text file. It is 0 if we
  11545. are reading from the terminal for normal input, or 1 if we are executing a
  11546. \&{readstring} command, or 2 if we are reading a string that was
  11547. moved into the buffer by \&{scantokens}.
  11548. @ Additional information about the current line is available via the
  11549. |index| variable, which counts how many lines of characters are present
  11550. in the buffer below the current level. We have |index=0| when reading
  11551. from the terminal and prompting the user for each line; then if the user types,
  11552. e.g., `\.{input font}', we will have |index=1| while reading
  11553. the file \.{font.mf}. However, it does not follow that |index| is the
  11554. same as the input stack pointer, since many of the levels on the input
  11555. stack may come from token lists.
  11556. The global variable |in_open| is equal to the |index|
  11557. value of the highest non-token-list level. Thus, the number of partially read
  11558. lines in the buffer is |in_open+1|, and we have |in_open=index|
  11559. when we are not reading a token list.
  11560. If we are not currently reading from the terminal,
  11561. we are reading from the file variable |input_file[index]|. We use
  11562. the notation |terminal_input| as a convenient abbreviation for |name=0|,
  11563. and |cur_file| as an abbreviation for |input_file[index]|.
  11564. The global variable |line| contains the line number in the topmost
  11565. open file, for use in error messages. If we are not reading from
  11566. the terminal, |line_stack[index]| holds the line number for the
  11567. enclosing level, so that |line| can be restored when the current
  11568. file has been read.
  11569. If more information about the input state is needed, it can be
  11570. included in small arrays like those shown here. For example,
  11571. the current page or segment number in the input file might be
  11572. put into a variable |@!page|, maintained for enclosing levels in
  11573. `\ignorespaces|@!page_stack:array[1..max_in_open] of integer|\unskip'
  11574. by analogy with |line_stack|.
  11575. @^system dependencies@>
  11576. @d terminal_input==(name=0) {are we reading from the terminal?}
  11577. @d cur_file==input_file[index] {the current |alpha_file| variable}
  11578. @<Glob...@>=
  11579. @!in_open : 0..max_in_open; {the number of lines in the buffer, less one}
  11580. @!open_parens : 0..max_in_open; {the number of open text files}
  11581. @!input_file : array[1..max_in_open] of alpha_file;
  11582. @!line : integer; {current line number in the current source file}
  11583. @!line_stack : array[1..max_in_open] of integer;
  11584. @ However, all this discussion about input state really applies only to the
  11585. case that we are inputting from a file. There is another important case,
  11586. namely when we are currently getting input from a token list. In this case
  11587. |index>max_in_open|, and the conventions about the other state variables
  11588. are different:
  11589. \yskip\hang|loc| is a pointer to the current node in the token list, i.e.,
  11590. the node that will be read next. If |loc=null|, the token list has been
  11591. fully read.
  11592. \yskip\hang|start| points to the first node of the token list; this node
  11593. may or may not contain a reference count, depending on the type of token
  11594. list involved.
  11595. \yskip\hang|token_type|, which takes the place of |index| in the
  11596. discussion above, is a code number that explains what kind of token list
  11597. is being scanned.
  11598. \yskip\hang|name| points to the |eqtb| address of the control sequence
  11599. being expanded, if the current token list is a macro not defined by
  11600. \&{vardef}. Macros defined by \&{vardef} have |name=null|; their name
  11601. can be deduced by looking at their first two parameters.
  11602. \yskip\hang|param_start|, which takes the place of |limit|, tells where
  11603. the parameters of the current macro or loop text begin in the |param_stack|.
  11604. \yskip\noindent The |token_type| can take several values, depending on
  11605. where the current token list came from:
  11606. \yskip
  11607. \indent|forever_text|, if the token list being scanned is the body of
  11608. a \&{forever} loop;
  11609. \indent|loop_text|, if the token list being scanned is the body of
  11610. a \&{for} or \&{forsuffixes} loop;
  11611. \indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned;
  11612. \indent|backed_up|, if the token list being scanned has been inserted as
  11613. `to be read again'.
  11614. \indent|inserted|, if the token list being scanned has been inserted as
  11615. part of error recovery;
  11616. \indent|macro|, if the expansion of a user-defined symbolic token is being
  11617. scanned.
  11618. \yskip\noindent
  11619. The token list begins with a reference count if and only if |token_type=
  11620. macro|.
  11621. @^reference counts@>
  11622. @d token_type==index {type of current token list}
  11623. @d token_state==(index>max_in_open) {are we scanning a token list?}
  11624. @d file_state==(index<=max_in_open) {are we scanning a file line?}
  11625. @d param_start==limit {base of macro parameters in |param_stack|}
  11626. @d forever_text=max_in_open+1 {|token_type| code for loop texts}
  11627. @d loop_text=max_in_open+2 {|token_type| code for loop texts}
  11628. @d parameter=max_in_open+3 {|token_type| code for parameter texts}
  11629. @d backed_up=max_in_open+4 {|token_type| code for texts to be reread}
  11630. @d inserted=max_in_open+5 {|token_type| code for inserted texts}
  11631. @d macro=max_in_open+6 {|token_type| code for macro replacement texts}
  11632. @ The |param_stack| is an auxiliary array used to hold pointers to the token
  11633. lists for parameters at the current level and subsidiary levels of input.
  11634. This stack grows at a different rate from the others.
  11635. @<Glob...@>=
  11636. @!param_stack:array [0..param_size] of pointer;
  11637.   {token list pointers for parameters}
  11638. @!param_ptr:0..param_size; {first unused entry in |param_stack|}
  11639. @!max_param_stack:integer;
  11640.   {largest value of |param_ptr|}
  11641. @ Thus, the ``current input state'' can be very complicated indeed; there
  11642. can be many levels and each level can arise in a variety of ways. The
  11643. |show_context| procedure, which is used by \MF's error-reporting routine to
  11644. print out the current input state on all levels down to the most recent
  11645. line of characters from an input file, illustrates most of these conventions.
  11646. The global variable |file_ptr| contains the lowest level that was
  11647. displayed by this procedure.
  11648. @<Glob...@>=
  11649. @!file_ptr:0..stack_size; {shallowest level shown by |show_context|}
  11650. @ The status at each level is indicated by printing two lines, where the first
  11651. line indicates what was read so far and the second line shows what remains
  11652. to be read. The context is cropped, if necessary, so that the first line
  11653. contains at most |half_error_line| characters, and the second contains
  11654. at most |error_line|. Non-current input levels whose |token_type| is
  11655. `|backed_up|' are shown only if they have not been fully read.
  11656. @p procedure show_context; {prints where the scanner is}
  11657. label done;
  11658. var @!old_setting:0..max_selector; {saved |selector| setting}
  11659. @<Local variables for formatting calculations@>@/
  11660. begin file_ptr:=input_ptr; input_stack[file_ptr]:=cur_input;
  11661.   {store current state}
  11662. loop@+begin cur_input:=input_stack[file_ptr]; {enter into the context}
  11663.   @<Display the current context@>;
  11664.   if file_state then
  11665.     if (name>2) or (file_ptr=0) then goto done;
  11666.   decr(file_ptr);
  11667.   end;
  11668. done: cur_input:=input_stack[input_ptr]; {restore original state}
  11669. @ @<Display the current context@>=
  11670. if (file_ptr=input_ptr) or file_state or
  11671.    (token_type<>backed_up) or (loc<>null) then
  11672.     {we omit backed-up token lists that have already been read}
  11673.   begin tally:=0; {get ready to count characters}
  11674.   old_setting:=selector;
  11675.   if file_state then
  11676.     begin @<Print location of current line@>;
  11677.     @<Pseudoprint the line@>;
  11678.     end
  11679.   else  begin @<Print type of token list@>;
  11680.     @<Pseudoprint the token list@>;
  11681.     end;
  11682.   selector:=old_setting; {stop pseudoprinting}
  11683.   @<Print two lines using the tricky pseudoprinted information@>;
  11684.   end
  11685. @ This routine should be changed, if necessary, to give the best possible
  11686. indication of where the current line resides in the input file.
  11687. For example, on some systems it is best to print both a page and line number.
  11688. @^system dependencies@>
  11689. @<Print location of current line@>=
  11690. if name<=1 then
  11691.   if terminal_input and(file_ptr=0) then print_nl("<*>")
  11692.   else print_nl("<insert>")
  11693. else if name=2 then print_nl("<scantokens>")
  11694. else  begin print_nl("l."); print_int(line);
  11695.   end;
  11696. print_char(" ")
  11697. @ @<Print type of token list@>=
  11698. case token_type of
  11699. forever_text: print_nl("<forever> ");
  11700. loop_text: @<Print the current loop value@>;
  11701. parameter: print_nl("<argument> ");
  11702. backed_up: if loc=null then print_nl("<recently read> ")
  11703.   else print_nl("<to be read again> ");
  11704. inserted: print_nl("<inserted text> ");
  11705. macro: begin print_ln;
  11706.   if name<>null then slow_print(text(name))
  11707.   else @<Print the name of a \&{vardef}'d macro@>;
  11708.   print("->");
  11709.   end;
  11710. othercases print_nl("?") {this should never happen}
  11711. @.?\relax@>
  11712. endcases
  11713. @ The parameter that corresponds to a loop text is either a token list
  11714. (in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}).
  11715. We'll discuss capsules later; for now, all we need to know is that
  11716. the |link| field in a capsule parameter is |void| and that
  11717. |print_exp(p,0)| displays the value of capsule~|p| in abbreviated form.
  11718. @<Print the current loop value@>=
  11719. begin print_nl("<for("); p:=param_stack[param_start];
  11720. if p<>null then
  11721.   if link(p)=void then print_exp(p,0) {we're in a \&{for} loop}
  11722.   else show_token_list(p,null,20,tally);
  11723. print(")> ");
  11724. @ The first two parameters of a macro defined by \&{vardef} will be token
  11725. lists representing the macro's prefix and ``at point.'' By putting these
  11726. together, we get the macro's full name.
  11727. @<Print the name of a \&{vardef}'d macro@>=
  11728. begin p:=param_stack[param_start];
  11729. if p=null then show_token_list(param_stack[param_start+1],null,20,tally)
  11730. else  begin q:=p;
  11731.   while link(q)<>null do q:=link(q);
  11732.   link(q):=param_stack[param_start+1];
  11733.   show_token_list(p,null,20,tally);
  11734.   link(q):=null;
  11735.   end;
  11736. @ Now it is necessary to explain a little trick. We don't want to store a long
  11737. string that corresponds to a token list, because that string might take up
  11738. lots of memory; and we are printing during a time when an error message is
  11739. being given, so we dare not do anything that might overflow one of \MF's
  11740. tables. So `pseudoprinting' is the answer: We enter a mode of printing
  11741. that stores characters into a buffer of length |error_line|, where character
  11742. $k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if
  11743. |k<trick_count|, otherwise character |k| is dropped. Initially we set
  11744. |tally:=0| and |trick_count:=1000000|; then when we reach the
  11745. point where transition from line 1 to line 2 should occur, we
  11746. set |first_count:=tally| and |trick_count:=@tmax@>(error_line,
  11747. tally+1+error_line-half_error_line)|. At the end of the
  11748. pseudoprinting, the values of |first_count|, |tally|, and
  11749. |trick_count| give us all the information we need to print the two lines,
  11750. and all of the necessary text is in |trick_buf|.
  11751. Namely, let |l| be the length of the descriptive information that appears
  11752. on the first line. The length of the context information gathered for that
  11753. line is |k=first_count|, and the length of the context information
  11754. gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|,
  11755. where |h=half_error_line|, we print |trick_buf[0..k-1]| after the
  11756. descriptive information on line~1, and set |n:=l+k|; here |n| is the
  11757. length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h|
  11758. and print `\.{...}' followed by
  11759. $$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$
  11760. where subscripts of |trick_buf| are circular modulo |error_line|. The
  11761. second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|,
  11762. unless |n+m>error_line|; in the latter case, further cropping is done.
  11763. This is easier to program than to explain.
  11764. @<Local variables for formatting...@>=
  11765. @!i:0..buf_size; {index into |buffer|}
  11766. @!l:integer; {length of descriptive information on line 1}
  11767. @!m:integer; {context information gathered for line 2}
  11768. @!n:0..error_line; {length of line 1}
  11769. @!p: integer; {starting or ending place in |trick_buf|}
  11770. @!q: integer; {temporary index}
  11771. @ The following code tells the print routines to gather
  11772. the desired information.
  11773. @d begin_pseudoprint==
  11774.   begin l:=tally; tally:=0; selector:=pseudo;
  11775.   trick_count:=1000000;
  11776.   end
  11777. @d set_trick_count==
  11778.   begin first_count:=tally;
  11779.   trick_count:=tally+1+error_line-half_error_line;
  11780.   if trick_count<error_line then trick_count:=error_line;
  11781.   end
  11782. @ And the following code uses the information after it has been gathered.
  11783. @<Print two lines using the tricky pseudoprinted information@>=
  11784. if trick_count=1000000 then set_trick_count;
  11785.   {|set_trick_count| must be performed}
  11786. if tally<trick_count then m:=tally-first_count
  11787. else m:=trick_count-first_count; {context on line 2}
  11788. if l+first_count<=half_error_line then
  11789.   begin p:=0; n:=l+first_count;
  11790.   end
  11791. else  begin print("..."); p:=l+first_count-half_error_line+3;
  11792.   n:=half_error_line;
  11793.   end;
  11794. for q:=p to first_count-1 do print_char(trick_buf[q mod error_line]);
  11795. print_ln;
  11796. for q:=1 to n do print_char(" "); {print |n| spaces to begin line~2}
  11797. if m+n<=error_line then p:=first_count+m else p:=first_count+(error_line-n-3);
  11798. for q:=first_count to p-1 do print_char(trick_buf[q mod error_line]);
  11799. if m+n>error_line then print("...")
  11800. @ But the trick is distracting us from our current goal, which is to
  11801. understand the input state. So let's concentrate on the data structures that
  11802. are being pseudoprinted as we finish up the |show_context| procedure.
  11803. @<Pseudoprint the line@>=
  11804. begin_pseudoprint;
  11805. if limit>0 then for i:=start to limit-1 do
  11806.   begin if i=loc then set_trick_count;
  11807.   print(buffer[i]);
  11808.   end
  11809. @ @<Pseudoprint the token list@>=
  11810. begin_pseudoprint;
  11811. if token_type<>macro then show_token_list(start,loc,100000,0)
  11812. else show_macro(start,loc,100000)
  11813. @ Here is the missing piece of |show_token_list| that is activated when the
  11814. token beginning line~2 is about to be shown:
  11815. @<Do magic computation@>=set_trick_count
  11816. @* \[32] Maintaining the input stacks.
  11817. The following subroutines change the input status in commonly needed ways.
  11818. First comes |push_input|, which stores the current state and creates a
  11819. new level (having, initially, the same properties as the old).
  11820. @d push_input==@t@> {enter a new input level, save the old}
  11821.   begin if input_ptr>max_in_stack then
  11822.     begin max_in_stack:=input_ptr;
  11823.     if input_ptr=stack_size then overflow("input stack size",stack_size);
  11824. @:METAFONT capacity exceeded input stack size}{\quad input stack size@>
  11825.     end;
  11826.   input_stack[input_ptr]:=cur_input; {stack the record}
  11827.   incr(input_ptr);
  11828.   end
  11829. @ And of course what goes up must come down.
  11830. @d pop_input==@t@> {leave an input level, re-enter the old}
  11831.   begin decr(input_ptr); cur_input:=input_stack[input_ptr];
  11832.   end
  11833. @ Here is a procedure that starts a new level of token-list input, given
  11834. a token list |p| and its type |t|. If |t=macro|, the calling routine should
  11835. set |name|, reset~|loc|, and increase the macro's reference count.
  11836. @d back_list(#)==begin_token_list(#,backed_up) {backs up a simple token list}
  11837. @p procedure begin_token_list(@!p:pointer;@!t:quarterword);
  11838. begin push_input; start:=p; token_type:=t;
  11839. param_start:=param_ptr; loc:=p;
  11840. @ When a token list has been fully scanned, the following computations
  11841. should be done as we leave that level of input.
  11842. @^inner loop@>
  11843. @p procedure end_token_list; {leave a token-list input level}
  11844. label done;
  11845. var @!p:pointer; {temporary register}
  11846. begin if token_type>=backed_up then {token list to be deleted}
  11847.   if token_type<=inserted then
  11848.     begin flush_token_list(start); goto done;
  11849.     end
  11850.   else delete_mac_ref(start); {update reference count}
  11851. while param_ptr>param_start do {parameters must be flushed}
  11852.   begin decr(param_ptr);
  11853.   p:=param_stack[param_ptr];
  11854.   if p<>null then
  11855.     if link(p)=void then {it's an \&{expr} parameter}
  11856.       begin recycle_value(p); free_node(p,value_node_size);
  11857.       end
  11858.     else flush_token_list(p); {it's a \&{suffix} or \&{text} parameter}
  11859.   end;
  11860. done: pop_input; check_interrupt;
  11861. @ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent
  11862. token by the |cur_tok| routine.
  11863. @^inner loop@>
  11864. @p @t\4@>@<Declare the procedure called |make_exp_copy|@>@;@/
  11865. function cur_tok:pointer;
  11866. var @!p:pointer; {a new token node}
  11867. @!save_type:small_number; {|cur_type| to be restored}
  11868. @!save_exp:integer; {|cur_exp| to be restored}
  11869. begin if cur_sym=0 then
  11870.   if cur_cmd=capsule_token then
  11871.     begin save_type:=cur_type; save_exp:=cur_exp;
  11872.     make_exp_copy(cur_mod); p:=stash_cur_exp; link(p):=null;
  11873.     cur_type:=save_type; cur_exp:=save_exp;
  11874.     end
  11875.   else  begin p:=get_node(token_node_size);
  11876.     value(p):=cur_mod; name_type(p):=token;
  11877.     if cur_cmd=numeric_token then type(p):=known
  11878.     else type(p):=string_type;
  11879.     end
  11880. else  begin fast_get_avail(p); info(p):=cur_sym;
  11881.   end;
  11882. cur_tok:=p;
  11883. @ Sometimes \MF\ has read too far and wants to ``unscan'' what it has
  11884. seen. The |back_input| procedure takes care of this by putting the token
  11885. just scanned back into the input stream, ready to be read again.
  11886. If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant.
  11887. @p procedure back_input; {undoes one token of input}
  11888. var @!p:pointer; {a token list of length one}
  11889. begin p:=cur_tok;
  11890. while token_state and(loc=null) do end_token_list; {conserve stack space}
  11891. back_list(p);
  11892. @ The |back_error| routine is used when we want to restore or replace an
  11893. offending token just before issuing an error message.  We disable interrupts
  11894. during the call of |back_input| so that the help message won't be lost.
  11895. @p procedure back_error; {back up one token and call |error|}
  11896. begin OK_to_interrupt:=false; back_input; OK_to_interrupt:=true; error;
  11897. procedure ins_error; {back up one inserted token and call |error|}
  11898. begin OK_to_interrupt:=false; back_input; token_type:=inserted;
  11899. OK_to_interrupt:=true; error;
  11900. @ The |begin_file_reading| procedure starts a new level of input for lines
  11901. of characters to be read from a file, or as an insertion from the
  11902. terminal. It does not take care of opening the file, nor does it set |loc|
  11903. or |limit| or |line|.
  11904. @^system dependencies@>
  11905. @p procedure begin_file_reading;
  11906. begin if in_open=max_in_open then overflow("text input levels",max_in_open);
  11907. @:METAFONT capacity exceeded text input levels}{\quad text input levels@>
  11908. if first=buf_size then overflow("buffer size",buf_size);
  11909. @:METAFONT capacity exceeded buffer size}{\quad buffer size@>
  11910. incr(in_open); push_input; index:=in_open;
  11911. line_stack[index]:=line; start:=first;
  11912. name:=0; {|terminal_input| is now |true|}
  11913. @ Conversely, the variables must be downdated when such a level of input
  11914. is finished:
  11915. @p procedure end_file_reading;
  11916. begin first:=start; line:=line_stack[index];
  11917. if index<>in_open then confusion("endinput");
  11918. @:this can't happen endinput}{\quad endinput@>
  11919. if name>2 then a_close(cur_file); {forget it}
  11920. pop_input; decr(in_open);
  11921. @ In order to keep the stack from overflowing during a long sequence of
  11922. inserted `\.{show}' commands, the following routine removes completed
  11923. error-inserted lines from memory.
  11924. @p procedure clear_for_error_prompt;
  11925. begin while file_state and terminal_input and@|
  11926.   (input_ptr>0)and(loc=limit) do end_file_reading;
  11927. print_ln; clear_terminal;
  11928. @ To get \MF's whole input mechanism going, we perform the following
  11929. actions.
  11930. @<Initialize the input routines@>=
  11931. begin input_ptr:=0; max_in_stack:=0;
  11932. in_open:=0; open_parens:=0; max_buf_stack:=0;
  11933. param_ptr:=0; max_param_stack:=0;
  11934. first:=1;
  11935. start:=1; index:=0; line:=0; name:=0;
  11936. force_eof:=false;
  11937. if not init_terminal then goto final_end;
  11938. limit:=last; first:=last+1; {|init_terminal| has set |loc| and |last|}
  11939. @* \[33] Getting the next token.
  11940. The heart of \MF's input mechanism is the |get_next| procedure, which
  11941. we shall develop in the next few sections of the program. Perhaps we
  11942. shouldn't actually call it the ``heart,'' however; it really acts as \MF's
  11943. eyes and mouth, reading the source files and gobbling them up. And it also
  11944. helps \MF\ to regurgitate stored token lists that are to be processed again.
  11945. The main duty of |get_next| is to input one token and to set |cur_cmd|
  11946. and |cur_mod| to that token's command code and modifier. Furthermore, if
  11947. the input token is a symbolic token, that token's |hash| address
  11948. is stored in |cur_sym|; otherwise |cur_sym| is set to zero.
  11949. Underlying this simple description is a certain amount of complexity
  11950. because of all the cases that need to be handled.
  11951. However, the inner loop of |get_next| is reasonably short and fast.
  11952. @ Before getting into |get_next|, we need to consider a mechanism by which
  11953. \MF\ helps keep errors from propagating too far. Whenever the program goes
  11954. into a mode where it keeps calling |get_next| repeatedly until a certain
  11955. condition is met, it sets |scanner_status| to some value other than |normal|.
  11956. Then if an input file ends, or if an `\&{outer}' symbol appears,
  11957. an appropriate error recovery will be possible.
  11958. The global variable |warning_info| helps in this error recovery by providing
  11959. additional information. For example, |warning_info| might indicate the
  11960. name of a macro whose replacement text is being scanned.
  11961. @d normal=0 {|scanner_status| at ``quiet times''}
  11962. @d skipping=1 {|scanner_status| when false conditional text is being skipped}
  11963. @d flushing=2 {|scanner_status| when junk after a statement is being ignored}
  11964. @d absorbing=3 {|scanner_status| when a \&{text} parameter is being scanned}
  11965. @d var_defining=4 {|scanner_status| when a \&{vardef} is being scanned}
  11966. @d op_defining=5 {|scanner_status| when a macro \&{def} is being scanned}
  11967. @d loop_defining=6 {|scanner_status| when a \&{for} loop is being scanned}
  11968. @<Glob...@>=
  11969. @!scanner_status:normal..loop_defining; {are we scanning at high speed?}
  11970. @!warning_info:integer; {if so, what else do we need to know,
  11971.     in case an error occurs?}
  11972. @ @<Initialize the input routines@>=
  11973. scanner_status:=normal;
  11974. @ The following subroutine
  11975. is called when an `\&{outer}' symbolic token has been scanned or
  11976. when the end of a file has been reached. These two cases are distinguished
  11977. by |cur_sym|, which is zero at the end of a file.
  11978. @p function check_outer_validity:boolean;
  11979. var @!p:pointer; {points to inserted token list}
  11980. begin if scanner_status=normal then check_outer_validity:=true
  11981. else  begin deletions_allowed:=false;
  11982.   @<Back up an outer symbolic token so that it can be reread@>;
  11983.   if scanner_status>skipping then
  11984.     @<Tell the user what has run away and try to recover@>
  11985.   else  begin print_err("Incomplete if; all text was ignored after line ");
  11986. @.Incomplete if...@>
  11987.     print_int(warning_info);@/
  11988.     help3("A forbidden `outer' token occurred in skipped text.")@/
  11989.     ("This kind of error happens when you say `if...' and forget")@/
  11990.     ("the matching `fi'. I've inserted a `fi'; this might work.");
  11991.     if cur_sym=0 then help_line[2]:=@|
  11992.       "The file ended while I was skipping conditional text.";
  11993.     cur_sym:=frozen_fi; ins_error;
  11994.     end;
  11995.   deletions_allowed:=true; check_outer_validity:=false;
  11996.   end;
  11997. @ @<Back up an outer symbolic token so that it can be reread@>=
  11998. if cur_sym<>0 then
  11999.   begin p:=get_avail; info(p):=cur_sym;
  12000.   back_list(p); {prepare to read the symbolic token again}
  12001.   end
  12002. @ @<Tell the user what has run away...@>=
  12003. begin runaway; {print the definition-so-far}
  12004. if cur_sym=0 then print_err("File ended")
  12005. @.File ended while scanning...@>
  12006. else  begin print_err("Forbidden token found");
  12007. @.Forbidden token found...@>
  12008.   end;
  12009. print(" while scanning ");
  12010. help4("I suspect you have forgotten an `enddef',")@/
  12011. ("causing me to read past where you wanted me to stop.")@/
  12012. ("I'll try to recover; but if the error is serious,")@/
  12013. ("you'd better type `E' or `X' now and fix your file.");@/
  12014. case scanner_status of
  12015. @t\4@>@<Complete the error message,
  12016.   and set |cur_sym| to a token that might help recover from the error@>@;
  12017. end; {there are no other cases}
  12018. ins_error;
  12019. @ As we consider various kinds of errors, it is also appropriate to
  12020. change the first line of the help message just given; |help_line[3]|
  12021. points to the string that might be changed.
  12022. @<Complete the error message,...@>=
  12023. flushing: begin print("to the end of the statement");
  12024.   help_line[3]:="A previous error seems to have propagated,";
  12025.   cur_sym:=frozen_semicolon;
  12026.   end;
  12027. absorbing: begin print("a text argument");
  12028.   help_line[3]:="It seems that a right delimiter was left out,";
  12029.   if warning_info=0 then cur_sym:=frozen_end_group
  12030.   else  begin cur_sym:=frozen_right_delimiter;
  12031.     equiv(frozen_right_delimiter):=warning_info;
  12032.     end;
  12033.   end;
  12034. var_defining, op_defining: begin print("the definition of ");
  12035.   if scanner_status=op_defining then slow_print(text(warning_info))
  12036.   else print_variable_name(warning_info);
  12037.   cur_sym:=frozen_end_def;
  12038.   end;
  12039. loop_defining: begin print("the text of a "); slow_print(text(warning_info));
  12040.   print(" loop");
  12041.   help_line[3]:="I suspect you have forgotten an `endfor',";
  12042.   cur_sym:=frozen_end_for;
  12043.   end;
  12044. @ The |runaway| procedure displays the first part of the text that occurred
  12045. when \MF\ began its special |scanner_status|, if that text has been saved.
  12046. @<Declare the procedure called |runaway|@>=
  12047. procedure runaway;
  12048. begin if scanner_status>flushing then
  12049.   begin print_nl("Runaway ");
  12050.   case scanner_status of
  12051.   absorbing: print("text?");
  12052.   var_defining,op_defining: print("definition?");
  12053.   loop_defining: print("loop?");
  12054.   end; {there are no other cases}
  12055.   print_ln; show_token_list(link(hold_head),null,error_line-10,0);
  12056.   end;
  12057. @ We need to mention a procedure that may be called by |get_next|.
  12058. @p procedure@?firm_up_the_line; forward;
  12059. @ And now we're ready to take the plunge into |get_next| itself.
  12060. @d switch=25 {a label in |get_next|}
  12061. @d start_numeric_token=85 {another}
  12062. @d start_decimal_token=86 {and another}
  12063. @d fin_numeric_token=87
  12064.   {and still another, although |goto| is considered harmful}
  12065. @p procedure get_next; {sets |cur_cmd|, |cur_mod|, |cur_sym| to next token}
  12066. @^inner loop@>
  12067. label restart, {go here to get the next input token}
  12068.   exit, {go here when the next input token has been got}
  12069.   found, {go here when the end of a symbolic token has been found}
  12070.   switch, {go here to branch on the class of an input character}
  12071.   start_numeric_token,start_decimal_token,fin_numeric_token,done;
  12072.     {go here at crucial stages when scanning a number}
  12073. var @!k:0..buf_size; {an index into |buffer|}
  12074. @!c:ASCII_code; {the current character in the buffer}
  12075. @!class:ASCII_code; {its class number}
  12076. @!n,@!f:integer; {registers for decimal-to-binary conversion}
  12077. begin restart: cur_sym:=0;
  12078. if file_state then
  12079. @<Input from external file; |goto restart| if no input found,
  12080.   or |return| if a non-symbolic token is found@>
  12081. else @<Input from token list; |goto restart| if end of list or
  12082.   if a parameter needs to be expanded,
  12083.   or |return| if a non-symbolic token is found@>;
  12084. @<Finish getting the symbolic token in |cur_sym|;
  12085.   |goto restart| if it is illegal@>;
  12086. exit:end;
  12087. @ When a symbolic token is declared to be `\&{outer}', its command code
  12088. is increased by |outer_tag|.
  12089. @^inner loop@>
  12090. @<Finish getting the symbolic token in |cur_sym|...@>=
  12091. cur_cmd:=eq_type(cur_sym); cur_mod:=equiv(cur_sym);
  12092. if cur_cmd>=outer_tag then
  12093.   if check_outer_validity then cur_cmd:=cur_cmd-outer_tag
  12094.   else goto restart
  12095. @ A percent sign appears in |buffer[limit]|; this makes it unnecessary
  12096. to have a special test for end-of-line.
  12097. @^inner loop@>
  12098. @<Input from external file;...@>=
  12099. begin switch: c:=buffer[loc]; incr(loc); class:=char_class[c];
  12100. case class of
  12101. digit_class: goto start_numeric_token;
  12102. period_class: begin class:=char_class[buffer[loc]];
  12103.   if class>period_class then goto switch
  12104.   else if class<period_class then {|class=digit_class|}
  12105.     begin n:=0; goto start_decimal_token;
  12106.     end;
  12107. @:. }{\..\ token@>
  12108.   end;
  12109. space_class: goto switch;
  12110. percent_class: begin @<Move to next line of file,
  12111.     or |goto restart| if there is no next line@>;
  12112.   check_interrupt;
  12113.   goto switch;
  12114.   end;
  12115. string_class: @<Get a string token and |return|@>;
  12116. isolated_classes: begin k:=loc-1; goto found;
  12117.   end;
  12118. invalid_class: @<Decry the invalid character and |goto restart|@>;
  12119. othercases do_nothing {letters, etc.}
  12120. endcases;@/
  12121. k:=loc-1;
  12122. while char_class[buffer[loc]]=class do incr(loc);
  12123. goto found;
  12124. start_numeric_token:@<Get the integer part |n| of a numeric token;
  12125.   set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>;
  12126. start_decimal_token:@<Get the fraction part |f| of a numeric token@>;
  12127. fin_numeric_token:@<Pack the numeric and fraction parts of a numeric token
  12128.   and |return|@>;
  12129. found: cur_sym:=id_lookup(k,loc-k);
  12130. @ We go to |restart| instead of to |switch|, because |state| might equal
  12131. |token_list| after the error has been dealt with
  12132. (cf.\ |clear_for_error_prompt|).
  12133. @<Decry the invalid...@>=
  12134. begin print_err("Text line contains an invalid character");
  12135. @.Text line contains...@>
  12136. help2("A funny symbol that I can't read has just been input.")@/
  12137. ("Continue, and I'll forget that it ever happened.");@/
  12138. deletions_allowed:=false; error; deletions_allowed:=true;
  12139. goto restart;
  12140. @ @<Get a string token and |return|@>=
  12141. begin if buffer[loc]="""" then cur_mod:=""
  12142. else  begin k:=loc; buffer[limit+1]:="""";
  12143.   repeat incr(loc);
  12144.   until buffer[loc]="""";
  12145.   if loc>limit then @<Decry the missing string delimiter and |goto restart|@>;
  12146.   if loc=k+1 then cur_mod:=buffer[k]
  12147.   else  begin str_room(loc-k);
  12148.     repeat append_char(buffer[k]); incr(k);
  12149.     until k=loc;
  12150.     cur_mod:=make_string;
  12151.     end;
  12152.   end;
  12153. incr(loc); cur_cmd:=string_token; return;
  12154. @ We go to |restart| after this error message, not to |switch|,
  12155. because the |clear_for_error_prompt| routine might have reinstated
  12156. |token_state| after |error| has finished.
  12157. @<Decry the missing string delimiter and |goto restart|@>=
  12158. begin loc:=limit; {the next character to be read on this line will be |"%"|}
  12159. print_err("Incomplete string token has been flushed");
  12160. @.Incomplete string token...@>
  12161. help3("Strings should finish on the same line as they began.")@/
  12162.   ("I've deleted the partial string; you might want to")@/
  12163.   ("insert another by typing, e.g., `I""new string""'.");@/
  12164. deletions_allowed:=false; error; deletions_allowed:=true; goto restart;
  12165. @ @<Get the integer part |n| of a numeric token...@>=
  12166. n:=c-"0";
  12167. while char_class[buffer[loc]]=digit_class do
  12168.   begin if n<4096 then n:=10*n+buffer[loc]-"0";
  12169.   incr(loc);
  12170.   end;
  12171. if buffer[loc]="." then if char_class[buffer[loc+1]]=digit_class then goto done;
  12172. f:=0; goto fin_numeric_token;
  12173. done: incr(loc)
  12174. @ @<Get the fraction part |f| of a numeric token@>=
  12175. k:=0;
  12176. repeat if k<17 then {digits for |k>=17| cannot affect the result}
  12177.   begin dig[k]:=buffer[loc]-"0"; incr(k);
  12178.   end;
  12179. incr(loc);
  12180. until char_class[buffer[loc]]<>digit_class;
  12181. f:=round_decimals(k);
  12182. if f=unity then
  12183.   begin incr(n); f:=0;
  12184.   end
  12185. @ @<Pack the numeric and fraction parts of a numeric token and |return|@>=
  12186. if n<4096 then cur_mod:=n*unity+f
  12187. else  begin print_err("Enormous number has been reduced");
  12188. @.Enormous number...@>
  12189.   help2("I can't handle numbers bigger than about 4095.99998;")@/
  12190.   ("so I've changed your constant to that maximum amount.");@/
  12191.   deletions_allowed:=false; error; deletions_allowed:=true;
  12192.   cur_mod:=@'1777777777;
  12193.   end;
  12194. cur_cmd:=numeric_token; return
  12195. @ Let's consider now what happens when |get_next| is looking at a token list.
  12196. @^inner loop@>
  12197. @<Input from token list;...@>=
  12198. if loc>=hi_mem_min then {one-word token}
  12199.   begin cur_sym:=info(loc); loc:=link(loc); {move to next}
  12200.   if cur_sym>=expr_base then
  12201.     if cur_sym>=suffix_base then
  12202.       @<Insert a suffix or text parameter and |goto restart|@>
  12203.     else  begin cur_cmd:=capsule_token;
  12204.       cur_mod:=param_stack[param_start+cur_sym-(expr_base)];
  12205.       cur_sym:=0; return;
  12206.       end;
  12207.   end
  12208. else if loc>null then
  12209.   @<Get a stored numeric or string or capsule token and |return|@>
  12210. else  begin {we are done with this token list}
  12211.   end_token_list; goto restart; {resume previous level}
  12212.   end
  12213. @ @<Insert a suffix or text parameter...@>=
  12214. begin if cur_sym>=text_base then cur_sym:=cur_sym-param_size;
  12215.   {|param_size=text_base-suffix_base|}
  12216. begin_token_list(param_stack[param_start+cur_sym-(suffix_base)],parameter);
  12217. goto restart;
  12218. @ @<Get a stored numeric or string or capsule token...@>=
  12219. begin if name_type(loc)=token then
  12220.   begin cur_mod:=value(loc);
  12221.   if type(loc)=known then cur_cmd:=numeric_token
  12222.   else  begin cur_cmd:=string_token; add_str_ref(cur_mod);
  12223.     end;
  12224.   end
  12225. else  begin cur_mod:=loc; cur_cmd:=capsule_token;
  12226.   end;
  12227. loc:=link(loc); return;
  12228. @ All of the easy branches of |get_next| have now been taken care of.
  12229. There is one more branch.
  12230. @<Move to next line of file, or |goto restart|...@>=
  12231. if name>2 then @<Read next line of file into |buffer|, or
  12232.   |goto restart| if the file has ended@>
  12233. else  begin if input_ptr>0 then
  12234.      {text was inserted during error recovery or by \&{scantokens}}
  12235.     begin end_file_reading; goto restart; {resume previous level}
  12236.     end;
  12237.   if selector<log_only then open_log_file;
  12238.   if interaction>nonstop_mode then
  12239.     begin if limit=start then {previous line was empty}
  12240.       print_nl("(Please type a command or say `end')");
  12241. @.Please type...@>
  12242.     print_ln; first:=start;
  12243.     prompt_input("*"); {input on-line into |buffer|}
  12244. @.*\relax@>
  12245.     limit:=last; buffer[limit]:="%";
  12246.     first:=limit+1; loc:=start;
  12247.     end
  12248.   else fatal_error("*** (job aborted, no legal end found)");
  12249. @.job aborted@>
  12250.     {nonstop mode, which is intended for overnight batch processing,
  12251.     never waits for on-line input}
  12252.   end
  12253. @ The global variable |force_eof| is normally |false|; it is set |true|
  12254. by an \&{endinput} command.
  12255. @<Glob...@>=
  12256. @!force_eof:boolean; {should the next \&{input} be aborted early?}
  12257. @ @<Read next line of file into |buffer|, or
  12258.   |goto restart| if the file has ended@>=
  12259. begin incr(line); first:=start;
  12260. if not force_eof then
  12261.   begin if input_ln(cur_file,true) then {not end of file}
  12262.     firm_up_the_line {this sets |limit|}
  12263.   else force_eof:=true;
  12264.   end;
  12265. if force_eof then
  12266.   begin print_char(")"); decr(open_parens);
  12267.   update_terminal; {show user that file has been read}
  12268.   force_eof:=false;
  12269.   end_file_reading; {resume previous level}
  12270.   if check_outer_validity then goto restart@+else goto restart;
  12271.   end;
  12272. buffer[limit]:="%"; first:=limit+1; loc:=start; {ready to read}
  12273. @ If the user has set the |pausing| parameter to some positive value,
  12274. and if nonstop mode has not been selected, each line of input is displayed
  12275. on the terminal and the transcript file, followed by `\.{=>}'.
  12276. \MF\ waits for a response. If the response is null (i.e., if nothing is
  12277. typed except perhaps a few blank spaces), the original
  12278. line is accepted as it stands; otherwise the line typed is
  12279. used instead of the line in the file.
  12280. @p procedure firm_up_the_line;
  12281. var @!k:0..buf_size; {an index into |buffer|}
  12282. begin limit:=last;
  12283. if internal[pausing]>0 then if interaction>nonstop_mode then
  12284.   begin wake_up_terminal; print_ln;
  12285.   if start<limit then for k:=start to limit-1 do print(buffer[k]);
  12286.   first:=limit; prompt_input("=>"); {wait for user response}
  12287. @.=>@>
  12288.   if last>first then
  12289.     begin for k:=first to last-1 do {move line down in buffer}
  12290.       buffer[k+start-first]:=buffer[k];
  12291.     limit:=start+last-first;
  12292.     end;
  12293.   end;
  12294. @* \[34] Scanning macro definitions.
  12295. \MF\ has a variety of ways to tuck tokens away into token lists for later
  12296. use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.;
  12297. repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}.
  12298. All such operations are handled by the routines in this part of the program.
  12299. The modifier part of each command code is zero for the ``ending delimiters''
  12300. like \&{enddef} and \&{endfor}.
  12301. @d start_def=1 {command modifier for \&{def}}
  12302. @d var_def=2 {command modifier for \&{vardef}}
  12303. @d end_def=0 {command modifier for \&{enddef}}
  12304. @d start_forever=1 {command modifier for \&{forever}}
  12305. @d end_for=0 {command modifier for \&{endfor}}
  12306. @<Put each...@>=
  12307. primitive("def",macro_def,start_def);@/
  12308. @!@:def_}{\&{def} primitive@>
  12309. primitive("vardef",macro_def,var_def);@/
  12310. @!@:var_def_}{\&{vardef} primitive@>
  12311. primitive("primarydef",macro_def,secondary_primary_macro);@/
  12312. @!@:primary_def_}{\&{primarydef} primitive@>
  12313. primitive("secondarydef",macro_def,tertiary_secondary_macro);@/
  12314. @!@:secondary_def_}{\&{secondarydef} primitive@>
  12315. primitive("tertiarydef",macro_def,expression_tertiary_macro);@/
  12316. @!@:tertiary_def_}{\&{tertiarydef} primitive@>
  12317. primitive("enddef",macro_def,end_def); eqtb[frozen_end_def]:=eqtb[cur_sym];@/
  12318. @!@:end_def_}{\&{enddef} primitive@>
  12319. primitive("for",iteration,expr_base);@/
  12320. @!@:for_}{\&{for} primitive@>
  12321. primitive("forsuffixes",iteration,suffix_base);@/
  12322. @!@:for_suffixes_}{\&{forsuffixes} primitive@>
  12323. primitive("forever",iteration,start_forever);@/
  12324. @!@:forever_}{\&{forever} primitive@>
  12325. primitive("endfor",iteration,end_for); eqtb[frozen_end_for]:=eqtb[cur_sym];@/
  12326. @!@:end_for_}{\&{endfor} primitive@>
  12327. @ @<Cases of |print_cmd...@>=
  12328. macro_def:if m<=var_def then
  12329.     if m=start_def then print("def")
  12330.     else if m<start_def then print("enddef")
  12331.     else print("vardef")
  12332.   else if m=secondary_primary_macro then print("primarydef")
  12333.   else if m=tertiary_secondary_macro then print("secondarydef")
  12334.   else print("tertiarydef");
  12335. iteration: if m<=start_forever then
  12336.     if m=start_forever then print("forever")@+else print("endfor")
  12337.   else if m=expr_base then print("for")@+else print("forsuffixes");
  12338. @ Different macro-absorbing operations have different syntaxes, but they
  12339. also have a lot in common. There is a list of special symbols that are to
  12340. be replaced by parameter tokens; there is a special command code that
  12341. ends the definition; the quotation conventions are identical.  Therefore
  12342. it makes sense to have most of the work done by a single subroutine. That
  12343. subroutine is called |scan_toks|.
  12344. The first parameter to |scan_toks| is the command code that will
  12345. terminate scanning (either |macro_def|, |loop_repeat|, or |iteration|).
  12346. The second parameter, |subst_list|, points to a (possibly empty) list
  12347. of two-word nodes whose |info| and |value| fields specify symbol tokens
  12348. before and after replacement. The list will be returned to free storage
  12349. by |scan_toks|.
  12350. The third parameter is simply appended to the token list that is built.
  12351. And the final parameter tells how many of the special operations
  12352. \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters.
  12353. When such parameters are present, they are called \.{(SUFFIX0)},
  12354. \.{(SUFFIX1)}, and \.{(SUFFIX2)}.
  12355. @p function scan_toks(@!terminator:command_code;
  12356.   @!subst_list,@!tail_end:pointer;@!suffix_count:small_number):pointer;
  12357. label done,found;
  12358. var @!p:pointer; {tail of the token list being built}
  12359. @!q:pointer; {temporary for link management}
  12360. @!balance:integer; {left delimiters minus right delimiters}
  12361. begin p:=hold_head; balance:=1; link(hold_head):=null;
  12362. loop@+  begin get_next;
  12363.   if cur_sym>0 then
  12364.     begin @<Substitute for |cur_sym|, if it's on the |subst_list|@>;
  12365.     if cur_cmd=terminator then
  12366.       @<Adjust the balance; |goto done| if it's zero@>
  12367.     else if cur_cmd=macro_special then
  12368.       @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>;
  12369.     end;
  12370.   link(p):=cur_tok; p:=link(p);
  12371.   end;
  12372. done: link(p):=tail_end; flush_node_list(subst_list);
  12373. scan_toks:=link(hold_head);
  12374. @ @<Substitute for |cur_sym|...@>=
  12375. begin q:=subst_list;
  12376. while q<>null do
  12377.   begin if info(q)=cur_sym then
  12378.     begin cur_sym:=value(q); cur_cmd:=relax; goto found;
  12379.     end;
  12380.   q:=link(q);
  12381.   end;
  12382. found:end
  12383. @ @<Adjust the balance; |goto done| if it's zero@>=
  12384. if cur_mod>0 then incr(balance)
  12385. else  begin decr(balance);
  12386.   if balance=0 then goto done;
  12387.   end
  12388. @ Four commands are intended to be used only within macro texts: \&{quote},
  12389. \.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command
  12390. code called |macro_special|.
  12391. @d quote=0 {|macro_special| modifier for \&{quote}}
  12392. @d macro_prefix=1 {|macro_special| modifier for \.{\#\AT!}}
  12393. @d macro_at=2 {|macro_special| modifier for \.{\AT!}}
  12394. @d macro_suffix=3 {|macro_special| modifier for \.{\AT!\#}}
  12395. @<Put each...@>=
  12396. primitive("quote",macro_special,quote);@/
  12397. @!@:quote_}{\&{quote} primitive@>
  12398. primitive("#@@",macro_special,macro_prefix);@/
  12399. @!@:]]]\#\AT!_}{\.{\#\AT!} primitive@>
  12400. primitive("@@",macro_special,macro_at);@/
  12401. @!@:]]]\AT!_}{\.{\AT!} primitive@>
  12402. primitive("@@#",macro_special,macro_suffix);@/
  12403. @!@:]]]\AT!\#_}{\.{\AT!\#} primitive@>
  12404. @ @<Cases of |print_cmd...@>=
  12405. macro_special: case m of
  12406.   macro_prefix: print("#@@");
  12407.   macro_at: print_char("@@");
  12408.   macro_suffix: print("@@#");
  12409.   othercases print("quote")
  12410.   endcases;
  12411. @ @<Handle quoted...@>=
  12412. begin if cur_mod=quote then get_next
  12413. else if cur_mod<=suffix_count then cur_sym:=suffix_base-1+cur_mod;
  12414. @ Here is a routine that's used whenever a token will be redefined. If
  12415. the user's token is unredefinable, the `|frozen_inaccessible|' token is
  12416. substituted; the latter is redefinable but essentially impossible to use,
  12417. hence \MF's tables won't get fouled up.
  12418. @p procedure get_symbol; {sets |cur_sym| to a safe symbol}
  12419. label restart;
  12420. begin restart: get_next;
  12421. if (cur_sym=0)or(cur_sym>frozen_inaccessible) then
  12422.   begin print_err("Missing symbolic token inserted");
  12423. @.Missing symbolic token...@>
  12424.   help3("Sorry: You can't redefine a number, string, or expr.")@/
  12425.     ("I've inserted an inaccessible symbol so that your")@/
  12426.     ("definition will be completed without mixing me up too badly.");
  12427.   if cur_sym>0 then
  12428.     help_line[2]:="Sorry: You can't redefine my error-recovery tokens."
  12429.   else if cur_cmd=string_token then delete_str_ref(cur_mod);
  12430.   cur_sym:=frozen_inaccessible; ins_error; goto restart;
  12431.   end;
  12432. @ Before we actually redefine a symbolic token, we need to clear away its
  12433. former value, if it was a variable. The following stronger version of
  12434. |get_symbol| does that.
  12435. @p procedure get_clear_symbol;
  12436. begin get_symbol; clear_symbol(cur_sym,false);
  12437. @ Here's another little subroutine; it checks that an equals sign
  12438. or assignment sign comes along at the proper place in a macro definition.
  12439. @p procedure check_equals;
  12440. begin if cur_cmd<>equals then if cur_cmd<>assignment then
  12441.   begin missing_err("=");@/
  12442. @.Missing `='@>
  12443.   help5("The next thing in this `def' should have been `=',")@/
  12444.     ("because I've already looked at the definition heading.")@/
  12445.     ("But don't worry; I'll pretend that an equals sign")@/
  12446.     ("was present. Everything from here to `enddef'")@/
  12447.     ("will be the replacement text of this macro.");
  12448.   back_error;
  12449.   end;
  12450. @ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily
  12451. handled now that we have |scan_toks|.  In this case there are
  12452. two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e.,
  12453. |expr_base| and |expr_base+1|).
  12454. @p procedure make_op_def;
  12455. var @!m:command_code; {the type of definition}
  12456. @!p,@!q,@!r:pointer; {for list manipulation}
  12457. begin m:=cur_mod;@/
  12458. get_symbol; q:=get_node(token_node_size);
  12459. info(q):=cur_sym; value(q):=expr_base;@/
  12460. get_clear_symbol; warning_info:=cur_sym;@/
  12461. get_symbol; p:=get_node(token_node_size);
  12462. info(p):=cur_sym; value(p):=expr_base+1; link(p):=q;@/
  12463. get_next; check_equals;@/
  12464. scanner_status:=op_defining; q:=get_avail; ref_count(q):=null;
  12465. r:=get_avail; link(q):=r; info(r):=general_macro;
  12466. link(r):=scan_toks(macro_def,p,null,0);
  12467. scanner_status:=normal; eq_type(warning_info):=m;
  12468. equiv(warning_info):=q; get_x_next;
  12469. @ Parameters to macros are introduced by the keywords \&{expr},
  12470. \&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}.
  12471. @<Put each...@>=
  12472. primitive("expr",param_type,expr_base);@/
  12473. @!@:expr_}{\&{expr} primitive@>
  12474. primitive("suffix",param_type,suffix_base);@/
  12475. @!@:suffix_}{\&{suffix} primitive@>
  12476. primitive("text",param_type,text_base);@/
  12477. @!@:text_}{\&{text} primitive@>
  12478. primitive("primary",param_type,primary_macro);@/
  12479. @!@:primary_}{\&{primary} primitive@>
  12480. primitive("secondary",param_type,secondary_macro);@/
  12481. @!@:secondary_}{\&{secondary} primitive@>
  12482. primitive("tertiary",param_type,tertiary_macro);@/
  12483. @!@:tertiary_}{\&{tertiary} primitive@>
  12484. @ @<Cases of |print_cmd...@>=
  12485. param_type:if m>=expr_base then
  12486.     if m=expr_base then print("expr")
  12487.     else if m=suffix_base then print("suffix")
  12488.     else print("text")
  12489.   else if m<secondary_macro then print("primary")
  12490.   else if m=secondary_macro then print("secondary")
  12491.   else print("tertiary");
  12492. @ Let's turn next to the more complex processing associated with \&{def}
  12493. and \&{vardef}. When the following procedure is called, |cur_mod|
  12494. should be either |start_def| or |var_def|.
  12495. @p @t\4@>@<Declare the procedure called |check_delimiter|@>@;
  12496. @t\4@>@<Declare the function called |scan_declared_variable|@>@;
  12497. procedure scan_def;
  12498. var @!m:start_def..var_def; {the type of definition}
  12499. @!n:0..3; {the number of special suffix parameters}
  12500. @!k:0..param_size; {the total number of parameters}
  12501. @!c:general_macro..text_macro; {the kind of macro we're defining}
  12502. @!r:pointer; {parameter-substitution list}
  12503. @!q:pointer; {tail of the macro token list}
  12504. @!p:pointer; {temporary storage}
  12505. @!base:halfword; {|expr_base|, |suffix_base|, or |text_base|}
  12506. @!l_delim,@!r_delim:pointer; {matching delimiters}
  12507. begin m:=cur_mod; c:=general_macro; link(hold_head):=null;@/
  12508. q:=get_avail; ref_count(q):=null; r:=null;@/
  12509. @<Scan the token or variable to be defined;
  12510.   set |n|, |scanner_status|, and |warning_info|@>;
  12511. k:=n;
  12512. if cur_cmd=left_delimiter then
  12513.   @<Absorb delimited parameters, putting them into lists |q| and |r|@>;
  12514. if cur_cmd=param_type then
  12515.   @<Absorb undelimited parameters, putting them into list |r|@>;
  12516. check_equals;
  12517. p:=get_avail; info(p):=c; link(q):=p;
  12518. @<Attach the replacement text to the tail of node |p|@>;
  12519. scanner_status:=normal; get_x_next;
  12520. @ We don't put `|frozen_end_group|' into the replacement text of
  12521. a \&{vardef}, because the user may want to redefine `\.{endgroup}'.
  12522. @<Attach the replacement text to the tail of node |p|@>=
  12523. if m=start_def then link(p):=scan_toks(macro_def,r,null,n)
  12524. else  begin q:=get_avail; info(q):=bg_loc; link(p):=q;
  12525.   p:=get_avail; info(p):=eg_loc;
  12526.   link(q):=scan_toks(macro_def,r,p,n);
  12527.   end;
  12528. if warning_info=bad_vardef then flush_token_list(value(bad_vardef))
  12529. @ @<Glob...@>=
  12530. @!bg_loc,@!eg_loc:1..hash_end;
  12531.   {hash addresses of `\.{begingroup}' and `\.{endgroup}'}
  12532. @ @<Scan the token or variable to be defined;...@>=
  12533. if m=start_def then
  12534.   begin get_clear_symbol; warning_info:=cur_sym; get_next;
  12535.   scanner_status:=op_defining; n:=0;
  12536.   eq_type(warning_info):=defined_macro; equiv(warning_info):=q;
  12537.   end
  12538. else  begin p:=scan_declared_variable;
  12539.   flush_variable(equiv(info(p)),link(p),true);
  12540.   warning_info:=find_variable(p); flush_list(p);
  12541.   if warning_info=null then @<Change to `\.{a bad variable}'@>;
  12542.   scanner_status:=var_defining; n:=2;
  12543.   if cur_cmd=macro_special then if cur_mod=macro_suffix then {\.{\AT!\#}}
  12544.     begin n:=3; get_next;
  12545.     end;
  12546.   type(warning_info):=unsuffixed_macro-2+n; value(warning_info):=q;
  12547.   end {|suffixed_macro=unsuffixed_macro+1|}
  12548. @ @<Change to `\.{a bad variable}'@>=
  12549. begin print_err("This variable already starts with a macro");
  12550. @.This variable already...@>
  12551. help2("After `vardef a' you can't say `vardef a.b'.")@/
  12552.   ("So I'll have to discard this definition.");
  12553. error; warning_info:=bad_vardef;
  12554. @ @<Initialize table entries...@>=
  12555. name_type(bad_vardef):=root; link(bad_vardef):=frozen_bad_vardef;
  12556. equiv(frozen_bad_vardef):=bad_vardef; eq_type(frozen_bad_vardef):=tag_token;
  12557. @ @<Absorb delimited parameters, putting them into lists |q| and |r|@>=
  12558. repeat l_delim:=cur_sym; r_delim:=cur_mod; get_next;
  12559. if (cur_cmd=param_type)and(cur_mod>=expr_base) then base:=cur_mod
  12560. else  begin print_err("Missing parameter type; `expr' will be assumed");
  12561. @.Missing parameter type@>
  12562.   help1("You should've had `expr' or `suffix' or `text' here.");
  12563.   back_error; base:=expr_base;
  12564.   end;
  12565. @<Absorb parameter tokens for type |base|@>;
  12566. check_delimiter(l_delim,r_delim);
  12567. get_next;
  12568. until cur_cmd<>left_delimiter
  12569. @ @<Absorb parameter tokens for type |base|@>=
  12570. repeat link(q):=get_avail; q:=link(q); info(q):=base+k;@/
  12571. get_symbol; p:=get_node(token_node_size); value(p):=base+k; info(p):=cur_sym;
  12572. if k=param_size then overflow("parameter stack size",param_size);
  12573. @:METAFONT capacity exceeded parameter stack size}{\quad parameter stack size@>
  12574. incr(k); link(p):=r; r:=p; get_next;
  12575. until cur_cmd<>comma
  12576. @ @<Absorb undelimited parameters, putting them into list |r|@>=
  12577. begin p:=get_node(token_node_size);
  12578. if cur_mod<expr_base then
  12579.   begin c:=cur_mod; value(p):=expr_base+k;
  12580.   end
  12581. else  begin value(p):=cur_mod+k;
  12582.   if cur_mod=expr_base then c:=expr_macro
  12583.   else if cur_mod=suffix_base then c:=suffix_macro
  12584.   else c:=text_macro;
  12585.   end;
  12586. if k=param_size then overflow("parameter stack size",param_size);
  12587. incr(k); get_symbol; info(p):=cur_sym; link(p):=r; r:=p; get_next;
  12588. if c=expr_macro then if cur_cmd=of_token then
  12589.   begin c:=of_macro; p:=get_node(token_node_size);
  12590.   if k=param_size then overflow("parameter stack size",param_size);
  12591.   value(p):=expr_base+k; get_symbol; info(p):=cur_sym;
  12592.   link(p):=r; r:=p; get_next;
  12593.   end;
  12594. @* \[35] Expanding the next token.
  12595. Only a few command codes |<min_command| can possibly be returned by
  12596. |get_next|; in increasing order, they are
  12597. |if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|,
  12598. |exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|.
  12599. \MF\ usually gets the next token of input by saying |get_x_next|. This is
  12600. like |get_next| except that it keeps getting more tokens until
  12601. finding |cur_cmd>=min_command|. In other words, |get_x_next| expands
  12602. macros and removes conditionals or iterations or input instructions that
  12603. might be present.
  12604. It follows that |get_x_next| might invoke itself recursively. In fact,
  12605. there is massive recursion, since macro expansion can involve the
  12606. scanning of arbitrarily complex expressions, which in turn involve
  12607. macro expansion and conditionals, etc.
  12608. @^recursion@>
  12609. Therefore it's necessary to declare a whole bunch of |forward|
  12610. procedures at this point, and to insert some other procedures
  12611. that will be invoked by |get_x_next|.
  12612. @p procedure@?scan_primary; forward;@t\2@>
  12613. procedure@?scan_secondary; forward;@t\2@>
  12614. procedure@?scan_tertiary; forward;@t\2@>
  12615. procedure@?scan_expression; forward;@t\2@>
  12616. procedure@?scan_suffix; forward;@t\2@>@/
  12617. @t\4@>@<Declare the procedure called |macro_call|@>@;@/
  12618. procedure@?get_boolean; forward;@t\2@>
  12619. procedure@?pass_text; forward;@t\2@>
  12620. procedure@?conditional; forward;@t\2@>
  12621. procedure@?start_input; forward;@t\2@>
  12622. procedure@?begin_iteration; forward;@t\2@>
  12623. procedure@?resume_iteration; forward;@t\2@>
  12624. procedure@?stop_iteration; forward;@t\2@>
  12625. @ An auxiliary subroutine called |expand| is used by |get_x_next|
  12626. when it has to do exotic expansion commands.
  12627. @p procedure expand;
  12628. var @!p:pointer; {for list manipulation}
  12629. @!k:integer; {something that we hope is |<=buf_size|}
  12630. @!j:pool_pointer; {index into |str_pool|}
  12631. begin if internal[tracing_commands]>unity then if cur_cmd<>defined_macro then
  12632.   show_cur_cmd_mod;
  12633. case cur_cmd of
  12634. if_test:conditional; {this procedure is discussed in Part 36 below}
  12635. fi_or_else:@<Terminate the current conditional and skip to \&{fi}@>;
  12636. input:@<Initiate or terminate input from a file@>;
  12637. iteration:if cur_mod=end_for then
  12638.     @<Scold the user for having an extra \&{endfor}@>
  12639.   else begin_iteration; {this procedure is discussed in Part 37 below}
  12640. repeat_loop: @<Repeat a loop@>;
  12641. exit_test: @<Exit a loop if the proper time has come@>;
  12642. relax: do_nothing;
  12643. expand_after: @<Expand the token after the next token@>;
  12644. scan_tokens: @<Put a string into the input buffer@>;
  12645. defined_macro:macro_call(cur_mod,null,cur_sym);
  12646. end; {there are no other cases}
  12647. @ @<Scold the user...@>=
  12648. begin print_err("Extra `endfor'");
  12649. @.Extra `endfor'@>
  12650. help2("I'm not currently working on a for loop,")@/
  12651.   ("so I had better not try to end anything.");@/
  12652. error;
  12653. @ The processing of \&{input} involves the |start_input| subroutine,
  12654. which will be declared later; the processing of \&{endinput} is trivial.
  12655. @<Put each...@>=
  12656. primitive("input",input,0);@/
  12657. @!@:input_}{\&{input} primitive@>
  12658. primitive("endinput",input,1);@/
  12659. @!@:end_input_}{\&{endinput} primitive@>
  12660. @ @<Cases of |print_cmd_mod|...@>=
  12661. input: if m=0 then print("input")@+else print("endinput");
  12662. @ @<Initiate or terminate input...@>=
  12663. if cur_mod>0 then force_eof:=true
  12664. else start_input
  12665. @ We'll discuss the complicated parts of loop operations later. For now
  12666. it suffices to know that there's a global variable called |loop_ptr|
  12667. that will be |null| if no loop is in progress.
  12668. @<Repeat a loop@>=
  12669. begin while token_state and(loc=null) do end_token_list; {conserve stack space}
  12670. if loop_ptr=null then
  12671.   begin print_err("Lost loop");
  12672. @.Lost loop@>
  12673.   help2("I'm confused; after exiting from a loop, I still seem")@/
  12674.     ("to want to repeat it. I'll try to forget the problem.");@/
  12675.   error;
  12676.   end
  12677. else resume_iteration; {this procedure is in Part 37 below}
  12678. @ @<Exit a loop if the proper time has come@>=
  12679. begin get_boolean;
  12680. if internal[tracing_commands]>unity then show_cmd_mod(nullary,cur_exp);
  12681. if cur_exp=true_code then
  12682.   if loop_ptr=null then
  12683.     begin print_err("No loop is in progress");
  12684. @.No loop is in progress@>
  12685.     help1("Why say `exitif' when there's nothing to exit from?");
  12686.     if cur_cmd=semicolon then error@+else back_error;
  12687.     end
  12688.   else @<Exit prematurely from an iteration@>
  12689. else if cur_cmd<>semicolon then
  12690.   begin missing_err(";");@/
  12691. @.Missing `;'@>
  12692.   help2("After `exitif <boolean exp>' I expect to see a semicolon.")@/
  12693.   ("I shall pretend that one was there."); back_error;
  12694.   end;
  12695. @ Here we use the fact that |forever_text| is the only |token_type| that
  12696. is less than |loop_text|.
  12697. @<Exit prematurely...@>=
  12698. begin p:=null;
  12699. repeat if file_state then end_file_reading
  12700. else  begin if token_type<=loop_text then p:=start;
  12701.   end_token_list;
  12702.   end;
  12703. until p<>null;
  12704. if p<>info(loop_ptr) then fatal_error("*** (loop confusion)");
  12705. @.loop confusion@>
  12706. stop_iteration; {this procedure is in Part 37 below}
  12707. @ @<Expand the token after the next token@>=
  12708. begin get_next;
  12709. p:=cur_tok; get_next;
  12710. if cur_cmd<min_command then expand else back_input;
  12711. back_list(p);
  12712. @ @<Put a string into the input buffer@>=
  12713. begin get_x_next; scan_primary;
  12714. if cur_type<>string_type then
  12715.   begin disp_err(null,"Not a string");
  12716. @.Not a string@>
  12717.   help2("I'm going to flush this expression, since")@/
  12718.     ("scantokens should be followed by a known string.");
  12719.   put_get_flush_error(0);
  12720.   end
  12721. else  begin back_input;
  12722.   if length(cur_exp)>0 then @<Pretend we're reading a new one-line file@>;
  12723.   end;
  12724. @ @<Pretend we're reading a new one-line file@>=
  12725. begin begin_file_reading; name:=2;
  12726. k:=first+length(cur_exp);
  12727. if k>=max_buf_stack then
  12728.   begin if k>=buf_size then
  12729.     begin max_buf_stack:=buf_size;
  12730.     overflow("buffer size",buf_size);
  12731. @:METAFONT capacity exceeded buffer size}{\quad buffer size@>
  12732.     end;
  12733.   max_buf_stack:=k+1;
  12734.   end;
  12735. j:=str_start[cur_exp]; limit:=k;
  12736. while first<limit do
  12737.   begin buffer[first]:=so(str_pool[j]); incr(j); incr(first);
  12738.   end;
  12739. buffer[limit]:="%"; first:=limit+1; loc:=start; flush_cur_exp(0);
  12740. @ Here finally is |get_x_next|.
  12741. The expression scanning routines to be considered later
  12742. communicate via the global quantities |cur_type| and |cur_exp|;
  12743. we must be very careful to save and restore these quantities while
  12744. macros are being expanded.
  12745. @^inner loop@>
  12746. @p procedure get_x_next;
  12747. var @!save_exp:pointer; {a capsule to save |cur_type| and |cur_exp|}
  12748. begin get_next;
  12749. if cur_cmd<min_command then
  12750.   begin save_exp:=stash_cur_exp;
  12751.   repeat if cur_cmd=defined_macro then macro_call(cur_mod,null,cur_sym)
  12752.   else expand;
  12753.   get_next;
  12754.   until cur_cmd>=min_command;
  12755.   unstash_cur_exp(save_exp); {that restores |cur_type| and |cur_exp|}
  12756.   end;
  12757. @ Now let's consider the |macro_call| procedure, which is used to start up
  12758. all user-defined macros. Since the arguments to a macro might be expressions,
  12759. |macro_call| is recursive.
  12760. @^recursion@>
  12761. The first parameter to |macro_call| points to the reference count of the
  12762. token list that defines the macro. The second parameter contains any
  12763. arguments that have already been parsed (see below).  The third parameter
  12764. points to the symbolic token that names the macro. If the third parameter
  12765. is |null|, the macro was defined by \&{vardef}, so its name can be
  12766. reconstructed from the prefix and ``at'' arguments found within the
  12767. second parameter.
  12768. What is this second parameter? It's simply a linked list of one-word items,
  12769. whose |info| fields point to the arguments. In other words, if |arg_list=null|,
  12770. no arguments have been scanned yet; otherwise |info(arg_list)| points to
  12771. the first scanned argument, and |link(arg_list)| points to the list of
  12772. further arguments (if any).
  12773. Arguments of type \&{expr} are so-called capsules, which we will
  12774. discuss later when we concentrate on expressions; they can be
  12775. recognized easily because their |link| field is |void|. Arguments of type
  12776. \&{suffix} and \&{text} are token lists without reference counts.
  12777. @ After argument scanning is complete, the arguments are moved to the
  12778. |param_stack|. (They can't be put on that stack any sooner, because
  12779. the stack is growing and shrinking in unpredictable ways as more arguments
  12780. are being acquired.)  Then the macro body is fed to the scanner; i.e.,
  12781. the replacement text of the macro is placed at the top of the \MF's
  12782. input stack, so that |get_next| will proceed to read it next.
  12783. @<Declare the procedure called |macro_call|@>=
  12784. @t\4@>@<Declare the procedure called |print_macro_name|@>@;
  12785. @t\4@>@<Declare the procedure called |print_arg|@>@;
  12786. @t\4@>@<Declare the procedure called |scan_text_arg|@>@;
  12787. procedure macro_call(@!def_ref,@!arg_list,@!macro_name:pointer);
  12788.   {invokes a user-defined control sequence}
  12789. label found;
  12790. var @!r:pointer; {current node in the macro's token list}
  12791. @!p,@!q:pointer; {for list manipulation}
  12792. @!n:integer; {the number of arguments}
  12793. @!l_delim,@!r_delim:pointer; {a delimiter pair}
  12794. @!tail:pointer; {tail of the argument list}
  12795. begin r:=link(def_ref); add_mac_ref(def_ref);
  12796. if arg_list=null then n:=0
  12797. else @<Determine the number |n| of arguments already supplied,
  12798.   and set |tail| to the tail of |arg_list|@>;
  12799. if internal[tracing_macros]>0 then
  12800.   @<Show the text of the macro being expanded, and the existing arguments@>;
  12801. @<Scan the remaining arguments, if any; set |r| to the first token
  12802.   of the replacement text@>;
  12803. @<Feed the arguments and replacement text to the scanner@>;
  12804. @ @<Show the text of the macro...@>=
  12805. begin begin_diagnostic; print_ln; print_macro_name(arg_list,macro_name);
  12806. if n=3 then print("@@#"); {indicate a suffixed macro}
  12807. show_macro(def_ref,null,100000);
  12808. if arg_list<>null then
  12809.   begin n:=0; p:=arg_list;
  12810.   repeat q:=info(p);
  12811.   print_arg(q,n,0);
  12812.   incr(n); p:=link(p);
  12813.   until p=null;
  12814.   end;
  12815. end_diagnostic(false);
  12816. @ @<Declare the procedure called |print_macro_name|@>=
  12817. procedure print_macro_name(@!a,@!n:pointer);
  12818. var @!p,@!q:pointer; {they traverse the first part of |a|}
  12819. begin if n<>null then slow_print(text(n))
  12820. else  begin p:=info(a);
  12821.   if p=null then slow_print(text(info(info(link(a)))))
  12822.   else  begin q:=p;
  12823.     while link(q)<>null do q:=link(q);
  12824.     link(q):=info(link(a));
  12825.     show_token_list(p,null,1000,0);
  12826.     link(q):=null;
  12827.     end;
  12828.   end;
  12829. @ @<Declare the procedure called |print_arg|@>=
  12830. procedure print_arg(@!q:pointer;@!n:integer;@!b:pointer);
  12831. begin if link(q)=void then print_nl("(EXPR")
  12832. else if (b<text_base)and(b<>text_macro) then print_nl("(SUFFIX")
  12833. else print_nl("(TEXT");
  12834. print_int(n); print(")<-");
  12835. if link(q)=void then print_exp(q,1)
  12836. else show_token_list(q,null,1000,0);
  12837. @ @<Determine the number |n| of arguments already supplied...@>=
  12838. begin n:=1; tail:=arg_list;
  12839. while link(tail)<>null do
  12840.   begin incr(n); tail:=link(tail);
  12841.   end;
  12842. @ @<Scan the remaining arguments, if any; set |r|...@>=
  12843. cur_cmd:=comma+1; {anything |<>comma| will do}
  12844. while info(r)>=expr_base do
  12845.   begin @<Scan the delimited argument represented by |info(r)|@>;
  12846.   r:=link(r);
  12847.   end;
  12848. if cur_cmd=comma then
  12849.   begin print_err("Too many arguments to ");
  12850. @.Too many arguments...@>
  12851.   print_macro_name(arg_list,macro_name); print_char(";");
  12852.   print_nl("  Missing `"); slow_print(text(r_delim));
  12853. @.Missing `)'...@>
  12854.   print("' has been inserted");
  12855.   help3("I'm going to assume that the comma I just read was a")@/
  12856.    ("right delimiter, and then I'll begin expanding the macro.")@/
  12857.    ("You might want to delete some tokens before continuing.");
  12858.   error;
  12859.   end;
  12860. if info(r)<>general_macro then @<Scan undelimited argument(s)@>;
  12861. r:=link(r)
  12862. @ At this point, the reader will find it advisable to review the explanation
  12863. of token list format that was presented earlier, paying special attention to
  12864. the conventions that apply only at the beginning of a macro's token list.
  12865. On the other hand, the reader will have to take the expression-parsing
  12866. aspects of the following program on faith; we will explain |cur_type|
  12867. and |cur_exp| later. (Several things in this program depend on each other,
  12868. and it's necessary to jump into the circle somewhere.)
  12869. @<Scan the delimited argument represented by |info(r)|@>=
  12870. if cur_cmd<>comma then
  12871.   begin get_x_next;
  12872.   if cur_cmd<>left_delimiter then
  12873.     begin print_err("Missing argument to ");
  12874. @.Missing argument...@>
  12875.     print_macro_name(arg_list,macro_name);
  12876.     help3("That macro has more parameters than you thought.")@/
  12877.      ("I'll continue by pretending that each missing argument")@/
  12878.      ("is either zero or null.");
  12879.     if info(r)>=suffix_base then
  12880.       begin cur_exp:=null; cur_type:=token_list;
  12881.       end
  12882.     else  begin cur_exp:=0; cur_type:=known;
  12883.       end;
  12884.     back_error; cur_cmd:=right_delimiter; goto found;
  12885.     end;
  12886.   l_delim:=cur_sym; r_delim:=cur_mod;
  12887.   end;
  12888. @<Scan the argument represented by |info(r)|@>;
  12889. if cur_cmd<>comma then @<Check that the proper right delimiter was present@>;
  12890. found:  @<Append the current expression to |arg_list|@>
  12891. @ @<Check that the proper right delim...@>=
  12892. if (cur_cmd<>right_delimiter)or(cur_mod<>l_delim) then
  12893.   if info(link(r))>=expr_base then
  12894.     begin missing_err(",");
  12895. @.Missing `,'@>
  12896.     help3("I've finished reading a macro argument and am about to")@/
  12897.       ("read another; the arguments weren't delimited correctly.")@/
  12898.        ("You might want to delete some tokens before continuing.");
  12899.     back_error; cur_cmd:=comma;
  12900.     end
  12901.   else  begin missing_err(text(r_delim));
  12902. @.Missing `)'@>
  12903.     help2("I've gotten to the end of the macro parameter list.")@/
  12904.        ("You might want to delete some tokens before continuing.");
  12905.     back_error;
  12906.     end
  12907. @ A \&{suffix} or \&{text} parameter will be have been scanned as
  12908. a token list pointed to by |cur_exp|, in which case we will have
  12909. |cur_type=token_list|.
  12910. @<Append the current expression to |arg_list|@>=
  12911. begin p:=get_avail;
  12912. if cur_type=token_list then info(p):=cur_exp
  12913. else info(p):=stash_cur_exp;
  12914. if internal[tracing_macros]>0 then
  12915.   begin begin_diagnostic; print_arg(info(p),n,info(r)); end_diagnostic(false);
  12916.   end;
  12917. if arg_list=null then arg_list:=p
  12918. else link(tail):=p;
  12919. tail:=p; incr(n);
  12920. @ @<Scan the argument represented by |info(r)|@>=
  12921. if info(r)>=text_base then scan_text_arg(l_delim,r_delim)
  12922. else  begin get_x_next;
  12923.   if info(r)>=suffix_base then scan_suffix
  12924.   else scan_expression;
  12925.   end
  12926. @ The parameters to |scan_text_arg| are either a pair of delimiters
  12927. or zero; the latter case is for undelimited text arguments, which
  12928. end with the first semicolon or \&{endgroup} or \&{end} that is not
  12929. contained in a group.
  12930. @<Declare the procedure called |scan_text_arg|@>=
  12931. procedure scan_text_arg(@!l_delim,@!r_delim:pointer);
  12932. label done;
  12933. var @!balance:integer; {excess of |l_delim| over |r_delim|}
  12934. @!p:pointer; {list tail}
  12935. begin warning_info:=l_delim; scanner_status:=absorbing;
  12936. p:=hold_head; balance:=1; link(hold_head):=null;
  12937. loop@+  begin get_next;
  12938.   if l_delim=0 then @<Adjust the balance for an undelimited argument;
  12939.     |goto done| if done@>
  12940.   else @<Adjust the balance for a delimited argument;
  12941.     |goto done| if done@>;
  12942.   link(p):=cur_tok; p:=link(p);
  12943.   end;
  12944. done: cur_exp:=link(hold_head); cur_type:=token_list;
  12945. scanner_status:=normal;
  12946. @ @<Adjust the balance for a delimited argument...@>=
  12947. begin if cur_cmd=right_delimiter then
  12948.   begin if cur_mod=l_delim then
  12949.     begin decr(balance);
  12950.     if balance=0 then goto done;
  12951.     end;
  12952.   end
  12953. else if cur_cmd=left_delimiter then if cur_mod=r_delim then incr(balance);
  12954. @ @<Adjust the balance for an undelimited...@>=
  12955. begin if end_of_statement then {|cur_cmd=semicolon|, |end_group|, or |stop|}
  12956.   begin if balance=1 then goto done
  12957.   else if cur_cmd=end_group then decr(balance);
  12958.   end
  12959. else if cur_cmd=begin_group then incr(balance);
  12960. @ @<Scan undelimited argument(s)@>=
  12961. begin if info(r)<text_macro then
  12962.   begin get_x_next;
  12963.   if info(r)<>suffix_macro then
  12964.     if (cur_cmd=equals)or(cur_cmd=assignment) then get_x_next;
  12965.   end;
  12966. case info(r) of
  12967. primary_macro:scan_primary;
  12968. secondary_macro:scan_secondary;
  12969. tertiary_macro:scan_tertiary;
  12970. expr_macro:scan_expression;
  12971. of_macro:@<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>;
  12972. suffix_macro:@<Scan a suffix with optional delimiters@>;
  12973. text_macro:scan_text_arg(0,0);
  12974. end; {there are no other cases}
  12975. back_input; @<Append the current expression to |arg_list|@>;
  12976. @ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>=
  12977. begin scan_expression; p:=get_avail; info(p):=stash_cur_exp;
  12978. if internal[tracing_macros]>0 then
  12979.   begin begin_diagnostic; print_arg(info(p),n,0); end_diagnostic(false);
  12980.   end;
  12981. if arg_list=null then arg_list:=p@+else link(tail):=p;
  12982. tail:=p;incr(n);
  12983. if cur_cmd<>of_token then
  12984.   begin missing_err("of"); print(" for ");
  12985. @.Missing `of'@>
  12986.   print_macro_name(arg_list,macro_name);
  12987.   help1("I've got the first argument; will look now for the other.");
  12988.   back_error;
  12989.   end;
  12990. get_x_next; scan_primary;
  12991. @ @<Scan a suffix with optional delimiters@>=
  12992. begin if cur_cmd<>left_delimiter then l_delim:=null
  12993. else  begin l_delim:=cur_sym; r_delim:=cur_mod; get_x_next;
  12994.   end;
  12995. scan_suffix;
  12996. if l_delim<>null then
  12997.   begin if(cur_cmd<>right_delimiter)or(cur_mod<>l_delim) then
  12998.     begin missing_err(text(r_delim));
  12999. @.Missing `)'@>
  13000.     help2("I've gotten to the end of the macro parameter list.")@/
  13001.        ("You might want to delete some tokens before continuing.");
  13002.     back_error;
  13003.     end;
  13004.   get_x_next;
  13005.   end;
  13006. @ Before we put a new token list on the input stack, it is wise to clean off
  13007. all token lists that have recently been depleted. Then a user macro that ends
  13008. with a call to itself will not require unbounded stack space.
  13009. @<Feed the arguments and replacement text to the scanner@>=
  13010. while token_state and(loc=null) do end_token_list; {conserve stack space}
  13011. if param_ptr+n>max_param_stack then
  13012.   begin max_param_stack:=param_ptr+n;
  13013.   if max_param_stack>param_size then
  13014.     overflow("parameter stack size",param_size);
  13015. @:METAFONT capacity exceeded parameter stack size}{\quad parameter stack size@>
  13016.   end;
  13017. begin_token_list(def_ref,macro); name:=macro_name; loc:=r;
  13018. if n>0 then
  13019.   begin p:=arg_list;
  13020.   repeat param_stack[param_ptr]:=info(p); incr(param_ptr); p:=link(p);
  13021.   until p=null;
  13022.   flush_list(arg_list);
  13023.   end
  13024. @ It's sometimes necessary to put a single argument onto |param_stack|.
  13025. The |stack_argument| subroutine does this.
  13026. @p procedure stack_argument(@!p:pointer);
  13027. begin if param_ptr=max_param_stack then
  13028.   begin incr(max_param_stack);
  13029.   if max_param_stack>param_size then
  13030.     overflow("parameter stack size",param_size);
  13031. @:METAFONT capacity exceeded parameter stack size}{\quad parameter stack size@>
  13032.   end;
  13033. param_stack[param_ptr]:=p; incr(param_ptr);
  13034. @* \[36] Conditional processing.
  13035. Let's consider now the way \&{if} commands are handled.
  13036. Conditions can be inside conditions, and this nesting has a stack
  13037. that is independent of other stacks.
  13038. Four global variables represent the top of the condition stack:
  13039. |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether
  13040. we are processing \&{if} or \&{elseif}; |if_limit| specifies
  13041. the largest code of a |fi_or_else| command that is syntactically legal;
  13042. and |if_line| is the line number at which the current conditional began.
  13043. If no conditions are currently in progress, the condition stack has the
  13044. special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|.
  13045. Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and
  13046. |link| fields of the first word contain |if_limit|, |cur_if|, and
  13047. |cond_ptr| at the next level, and the second word contains the
  13048. corresponding |if_line|.
  13049. @d if_node_size=2 {number of words in stack entry for conditionals}
  13050. @d if_line_field(#)==mem[#+1].int
  13051. @d if_code=1 {code for \&{if} being evaluated}
  13052. @d fi_code=2 {code for \&{fi}}
  13053. @d else_code=3 {code for \&{else}}
  13054. @d else_if_code=4 {code for \&{elseif}}
  13055. @<Glob...@>=
  13056. @!cond_ptr:pointer; {top of the condition stack}
  13057. @!if_limit:normal..else_if_code; {upper bound on |fi_or_else| codes}
  13058. @!cur_if:small_number; {type of conditional being worked on}
  13059. @!if_line:integer; {line where that conditional began}
  13060. @ @<Set init...@>=
  13061. cond_ptr:=null; if_limit:=normal; cur_if:=0; if_line:=0;
  13062. @ @<Put each...@>=
  13063. primitive("if",if_test,if_code);@/
  13064. @!@:if_}{\&{if} primitive@>
  13065. primitive("fi",fi_or_else,fi_code); eqtb[frozen_fi]:=eqtb[cur_sym];@/
  13066. @!@:fi_}{\&{fi} primitive@>
  13067. primitive("else",fi_or_else,else_code);@/
  13068. @!@:else_}{\&{else} primitive@>
  13069. primitive("elseif",fi_or_else,else_if_code);@/
  13070. @!@:else_if_}{\&{elseif} primitive@>
  13071. @ @<Cases of |print_cmd_mod|...@>=
  13072. if_test,fi_or_else: case m of
  13073.   if_code:print("if");
  13074.   fi_code:print("fi");
  13075.   else_code:print("else");
  13076.   othercases print("elseif")
  13077.   endcases;
  13078. @ Here is a procedure that ignores text until coming to an \&{elseif},
  13079. \&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$
  13080. nesting. After it has acted, |cur_mod| will indicate the token that
  13081. was found.
  13082. \MF's smallest two command codes are |if_test| and |fi_or_else|; this
  13083. makes the skipping process a bit simpler.
  13084. @p procedure pass_text;
  13085. label done;
  13086. var l:integer;
  13087. begin scanner_status:=skipping; l:=0; warning_info:=line;
  13088. loop@+  begin get_next;
  13089.   if cur_cmd<=fi_or_else then
  13090.     if cur_cmd<fi_or_else then incr(l)
  13091.     else  begin if l=0 then goto done;
  13092.       if cur_mod=fi_code then decr(l);
  13093.       end
  13094.   else @<Decrease the string reference count,
  13095.     if the current token is a string@>;
  13096.   end;
  13097. done: scanner_status:=normal;
  13098. @ @<Decrease the string reference count...@>=
  13099. if cur_cmd=string_token then delete_str_ref(cur_mod)
  13100. @ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then
  13101. if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if}
  13102. condition has been evaluated, a colon will be inserted.
  13103. A construction like `\.{if fi}' would otherwise get \MF\ confused.
  13104. @<Push the condition stack@>=
  13105. begin p:=get_node(if_node_size); link(p):=cond_ptr; type(p):=if_limit;
  13106. name_type(p):=cur_if; if_line_field(p):=if_line;
  13107. cond_ptr:=p; if_limit:=if_code; if_line:=line; cur_if:=if_code;
  13108. @ @<Pop the condition stack@>=
  13109. begin p:=cond_ptr; if_line:=if_line_field(p);
  13110. cur_if:=name_type(p); if_limit:=type(p); cond_ptr:=link(p);
  13111. free_node(p,if_node_size);
  13112. @ Here's a procedure that changes the |if_limit| code corresponding to
  13113. a given value of |cond_ptr|.
  13114. @p procedure change_if_limit(@!l:small_number;@!p:pointer);
  13115. label exit;
  13116. var q:pointer;
  13117. begin if p=cond_ptr then if_limit:=l {that's the easy case}
  13118. else  begin q:=cond_ptr;
  13119.   loop@+  begin if q=null then confusion("if");
  13120. @:this can't happen if}{\quad if@>
  13121.     if link(q)=p then
  13122.       begin type(q):=l; return;
  13123.       end;
  13124.     q:=link(q);
  13125.     end;
  13126.   end;
  13127. exit:end;
  13128. @ The user is supposed to put colons into the proper parts of conditional
  13129. statements. Therefore, \MF\ has to check for their presence.
  13130. @p procedure check_colon;
  13131. begin if cur_cmd<>colon then
  13132.   begin missing_err(":");@/
  13133. @.Missing `:'@>
  13134.   help2("There should've been a colon after the condition.")@/
  13135.     ("I shall pretend that one was there.");@;
  13136.   back_error;
  13137.   end;
  13138. @ A condition is started when the |get_x_next| procedure encounters
  13139. an |if_test| command; in that case |get_x_next| calls |conditional|,
  13140. which is a recursive procedure.
  13141. @^recursion@>
  13142. @p procedure conditional;
  13143. label exit,done,reswitch,found;
  13144. var @!save_cond_ptr:pointer; {|cond_ptr| corresponding to this conditional}
  13145. @!new_if_limit:fi_code..else_if_code; {future value of |if_limit|}
  13146. @!p:pointer; {temporary register}
  13147. begin @<Push the condition stack@>;@+save_cond_ptr:=cond_ptr;
  13148. reswitch: get_boolean; new_if_limit:=else_if_code;
  13149. if internal[tracing_commands]>unity then
  13150.   @<Display the boolean value of |cur_exp|@>;
  13151. found: check_colon;
  13152. if cur_exp=true_code then
  13153.   begin change_if_limit(new_if_limit,save_cond_ptr);
  13154.   return; {wait for \&{elseif}, \&{else}, or \&{fi}}
  13155.   end;
  13156. @<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>;
  13157. done: cur_if:=cur_mod; if_line:=line;
  13158. if cur_mod=fi_code then @<Pop the condition stack@>
  13159. else if cur_mod=else_if_code then goto reswitch
  13160. else  begin cur_exp:=true_code; new_if_limit:=fi_code; get_x_next; goto found;
  13161.   end;
  13162. exit:end;
  13163. @ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo}
  13164. \&{else}: \\{bar} \&{fi}', the first \&{else}
  13165. that we come to after learning that the \&{if} is false is not the
  13166. \&{else} we're looking for. Hence the following curious logic is needed.
  13167. @<Skip to \&{elseif}...@>=
  13168. loop@+  begin pass_text;
  13169.   if cond_ptr=save_cond_ptr then goto done
  13170.   else if cur_mod=fi_code then @<Pop the condition stack@>;
  13171.   end
  13172. @ @<Display the boolean value...@>=
  13173. begin begin_diagnostic;
  13174. if cur_exp=true_code then print("{true}")@+else print("{false}");
  13175. end_diagnostic(false);
  13176. @ The processing of conditionals is complete except for the following
  13177. code, which is actually part of |get_x_next|. It comes into play when
  13178. \&{elseif}, \&{else}, or \&{fi} is scanned.
  13179. @<Terminate the current conditional and skip to \&{fi}@>=
  13180. if cur_mod>if_limit then
  13181.   if if_limit=if_code then {condition not yet evaluated}
  13182.     begin missing_err(":");
  13183. @.Missing `:'@>
  13184.     back_input; cur_sym:=frozen_colon; ins_error;
  13185.     end
  13186.   else  begin print_err("Extra "); print_cmd_mod(fi_or_else,cur_mod);
  13187. @.Extra else@>
  13188. @.Extra elseif@>
  13189. @.Extra fi@>
  13190.     help1("I'm ignoring this; it doesn't match any if.");
  13191.     error;
  13192.     end
  13193. else  begin while cur_mod<>fi_code do pass_text; {skip to \&{fi}}
  13194.   @<Pop the condition stack@>;
  13195.   end
  13196. @* \[37] Iterations.
  13197. To bring our treatment of |get_x_next| to a close, we need to consider what
  13198. \MF\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}.
  13199. There's a global variable |loop_ptr| that keeps track of the \&{for} loops
  13200. that are currently active. If |loop_ptr=null|, no loops are in progress;
  13201. otherwise |info(loop_ptr)| points to the iterative text of the current
  13202. (innermost) loop, and |link(loop_ptr)| points to the data for any other
  13203. loops that enclose the current one.
  13204. A loop-control node also has two other fields, called |loop_type| and
  13205. |loop_list|, whose contents depend on the type of loop:
  13206. \yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)|
  13207. points to a list of one-word nodes whose |info| fields point to the
  13208. remaining argument values of a suffix list and expression list.
  13209. \yskip\indent|loop_type(loop_ptr)=void| means that the current loop is
  13210. `\&{forever}'.
  13211. \yskip\indent|loop_type(loop_ptr)=p>void| means that |value(p)|,
  13212. |step_size(p)|, and |final_value(p)| contain the data for an arithmetic
  13213. progression.
  13214. \yskip\noindent In the latter case, |p| points to a ``progression node''
  13215. whose first word is not used. (No value could be stored there because the
  13216. link field of words in the dynamic memory area cannot be arbitrary.)
  13217. @d loop_list_loc(#)==#+1 {where the |loop_list| field resides}
  13218. @d loop_type(#)==info(loop_list_loc(#)) {the type of \&{for} loop}
  13219. @d loop_list(#)==link(loop_list_loc(#)) {the remaining list elements}
  13220. @d loop_node_size=2 {the number of words in a loop control node}
  13221. @d progression_node_size=4 {the number of words in a progression node}
  13222. @d step_size(#)==mem[#+2].sc {the step size in an arithmetic progression}
  13223. @d final_value(#)==mem[#+3].sc {the final value in an arithmetic progression}
  13224. @<Glob...@>=
  13225. @!loop_ptr:pointer; {top of the loop-control-node stack}
  13226. @ @<Set init...@>=
  13227. loop_ptr:=null;
  13228. @ If the expressions that define an arithmetic progression in
  13229. a \&{for} loop don't have known numeric values, the |bad_for|
  13230. subroutine screams at the user.
  13231. @p procedure bad_for(@!s:str_number);
  13232. begin disp_err(null,"Improper "); {show the bad expression above the message}
  13233. @.Improper...replaced by 0@>
  13234. print(s); print(" has been replaced by 0");
  13235. help4("When you say `for x=a step b until c',")@/
  13236.   ("the initial value `a' and the step size `b'")@/
  13237.   ("and the final value `c' must have known numeric values.")@/
  13238.   ("I'm zeroing this one. Proceed, with fingers crossed.");
  13239. put_get_flush_error(0);
  13240. @ Here's what \MF\ does when \&{for}, \&{forsuffixes}, or \&{forever}
  13241. has just been scanned. (This code requires slight familiarity with
  13242. expression-parsing routines that we have not yet discussed; but it seems
  13243. to belong in the present part of the program, even though the author
  13244. didn't write it until later. The reader may wish to come back to it.)
  13245. @p procedure begin_iteration;
  13246. label continue,done,found;
  13247. var @!m:halfword; {|expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes})}
  13248. @!n:halfword; {hash address of the current symbol}
  13249. @!p,@!q,@!s,@!pp:pointer; {link manipulation registers}
  13250. begin m:=cur_mod; n:=cur_sym; s:=get_node(loop_node_size);
  13251. if m=start_forever then
  13252.   begin loop_type(s):=void; p:=null; get_x_next; goto found;
  13253.   end;
  13254. get_symbol; p:=get_node(token_node_size); info(p):=cur_sym; value(p):=m;@/
  13255. get_x_next;
  13256. if (cur_cmd<>equals)and(cur_cmd<>assignment) then
  13257.   begin missing_err("=");@/
  13258. @.Missing `='@>
  13259.   help3("The next thing in this loop should have been `=' or `:='.")@/
  13260.     ("But don't worry; I'll pretend that an equals sign")@/
  13261.     ("was present, and I'll look for the values next.");@/
  13262.   back_error;
  13263.   end;
  13264. @<Scan the values to be used in the loop@>;
  13265. found:@<Check for the presence of a colon@>;
  13266. @<Scan the loop text and put it on the loop control stack@>;
  13267. resume_iteration;
  13268. @ @<Check for the presence of a colon@>=
  13269. if cur_cmd<>colon then
  13270.   begin missing_err(":");@/
  13271. @.Missing `:'@>
  13272.   help3("The next thing in this loop should have been a `:'.")@/
  13273.     ("So I'll pretend that a colon was present;")@/
  13274.     ("everything from here to `endfor' will be iterated.");
  13275.   back_error;
  13276.   end
  13277. @ We append a special |frozen_repeat_loop| token in place of the
  13278. `\&{endfor}' at the end of the loop. This will come through \MF's scanner
  13279. at the proper time to cause the loop to be repeated.
  13280. (If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}',
  13281. he will be foiled by the |get_symbol| routine, which keeps frozen
  13282. tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer}
  13283. token, so it won't be lost accidentally.)
  13284. @ @<Scan the loop text...@>=
  13285. q:=get_avail; info(q):=frozen_repeat_loop;
  13286. scanner_status:=loop_defining; warning_info:=n;
  13287. info(s):=scan_toks(iteration,p,q,0); scanner_status:=normal;@/
  13288. link(s):=loop_ptr; loop_ptr:=s
  13289. @ @<Initialize table...@>=
  13290. eq_type(frozen_repeat_loop):=repeat_loop+outer_tag;
  13291. text(frozen_repeat_loop):=" ENDFOR";
  13292. @ The loop text is inserted into \MF's scanning apparatus by the
  13293. |resume_iteration| routine.
  13294. @p procedure resume_iteration;
  13295. label not_found,exit;
  13296. var @!p,@!q:pointer; {link registers}
  13297. begin p:=loop_type(loop_ptr);
  13298. if p>void then {|p| points to a progression node}
  13299.   begin cur_exp:=value(p);
  13300.   if @<The arithmetic progression has ended@> then goto not_found;
  13301.   cur_type:=known; q:=stash_cur_exp; {make |q| an \&{expr} argument}
  13302.   value(p):=cur_exp+step_size(p); {set |value(p)| for the next iteration}
  13303.   end
  13304. else if p<void then
  13305.   begin p:=loop_list(loop_ptr);
  13306.   if p=null then goto not_found;
  13307.   loop_list(loop_ptr):=link(p); q:=info(p); free_avail(p);
  13308.   end
  13309. else  begin begin_token_list(info(loop_ptr),forever_text); return;
  13310.   end;
  13311. begin_token_list(info(loop_ptr),loop_text);
  13312. stack_argument(q);
  13313. if internal[tracing_commands]>unity then @<Trace the start of a loop@>;
  13314. return;
  13315. not_found:stop_iteration;
  13316. exit:end;
  13317. @ @<The arithmetic progression has ended@>=
  13318. ((step_size(p)>0)and(cur_exp>final_value(p)))or@|
  13319.  ((step_size(p)<0)and(cur_exp<final_value(p)))
  13320. @ @<Trace the start of a loop@>=
  13321. begin begin_diagnostic; print_nl("{loop value=");
  13322. @.loop value=n@>
  13323. if (q<>null)and(link(q)=void) then print_exp(q,1)
  13324. else show_token_list(q,null,50,0);
  13325. print_char("}"); end_diagnostic(false);
  13326. @ A level of loop control disappears when |resume_iteration| has decided
  13327. not to resume, or when an \&{exitif} construction has removed the loop text
  13328. from the input stack.
  13329. @p procedure stop_iteration;
  13330. var @!p,@!q:pointer; {the usual}
  13331. begin p:=loop_type(loop_ptr);
  13332. if p>void then free_node(p,progression_node_size)
  13333. else if p<void then
  13334.   begin q:=loop_list(loop_ptr);
  13335.   while q<>null do
  13336.     begin p:=info(q);
  13337.     if p<>null then
  13338.       if link(p)=void then {it's an \&{expr} parameter}
  13339.         begin recycle_value(p); free_node(p,value_node_size);
  13340.         end
  13341.       else flush_token_list(p); {it's a \&{suffix} or \&{text} parameter}
  13342.     p:=q; q:=link(q); free_avail(p);
  13343.     end;
  13344.   end;
  13345. p:=loop_ptr; loop_ptr:=link(p); flush_token_list(info(p));
  13346. free_node(p,loop_node_size);
  13347. @ Now that we know all about loop control, we can finish up
  13348. the missing portion of |begin_iteration| and we'll be done.
  13349. The following code is performed after the `\.=' has been scanned in
  13350. a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction
  13351. (if |m=suffix_base|).
  13352. @<Scan the values to be used in the loop@>=
  13353. loop_type(s):=null; q:=loop_list_loc(s); link(q):=null; {|link(q)=loop_list(s)|}
  13354. repeat get_x_next;
  13355. if m<>expr_base then scan_suffix
  13356. else  begin if cur_cmd>=colon then if cur_cmd<=comma then goto continue;
  13357.   scan_expression;
  13358.   if cur_cmd=step_token then if q=loop_list_loc(s) then
  13359.     @<Prepare for step-until construction and |goto done|@>;
  13360.   cur_exp:=stash_cur_exp;
  13361.   end;
  13362. link(q):=get_avail; q:=link(q); info(q):=cur_exp; cur_type:=vacuous;
  13363. continue: until cur_cmd<>comma;
  13364. done:
  13365. @ @<Prepare for step-until construction and |goto done|@>=
  13366. begin if cur_type<>known then bad_for("initial value");
  13367. pp:=get_node(progression_node_size); value(pp):=cur_exp;@/
  13368. get_x_next; scan_expression;
  13369. if cur_type<>known then bad_for("step size");
  13370. step_size(pp):=cur_exp;
  13371. if cur_cmd<>until_token then
  13372.   begin missing_err("until");@/
  13373. @.Missing `until'@>
  13374.   help2("I assume you meant to say `until' after `step'.")@/
  13375.     ("So I'll look for the final value and colon next.");
  13376.   back_error;
  13377.   end;
  13378. get_x_next; scan_expression;
  13379. if cur_type<>known then bad_for("final value");
  13380. final_value(pp):=cur_exp; loop_type(s):=pp; goto done;
  13381. @* \[38] File names.
  13382. It's time now to fret about file names.  Besides the fact that different
  13383. operating systems treat files in different ways, we must cope with the
  13384. fact that completely different naming conventions are used by different
  13385. groups of people. The following programs show what is required for one
  13386. particular operating system; similar routines for other systems are not
  13387. difficult to devise.
  13388. @^system dependencies@>
  13389. \MF\ assumes that a file name has three parts: the name proper; its
  13390. ``extension''; and a ``file area'' where it is found in an external file
  13391. system.  The extension of an input file is assumed to be
  13392. `\.{.mf}' unless otherwise specified; it is `\.{.log}' on the
  13393. transcript file that records each run of \MF; it is `\.{.tfm}' on the font
  13394. metric files that describe characters in the fonts \MF\ creates; it is
  13395. `\.{.gf}' on the output files that specify generic font information; and it
  13396. is `\.{.base}' on the base files written by \.{INIMF} to initialize \MF.
  13397. The file area can be arbitrary on input files, but files are usually
  13398. output to the user's current area.  If an input file cannot be
  13399. found on the specified area, \MF\ will look for it on a special system
  13400. area; this special area is intended for commonly used input files.
  13401. Simple uses of \MF\ refer only to file names that have no explicit
  13402. extension or area. For example, a person usually says `\.{input} \.{cmr10}'
  13403. instead of `\.{input} \.{cmr10.new}'. Simple file
  13404. names are best, because they make the \MF\ source files portable;
  13405. whenever a file name consists entirely of letters and digits, it should be
  13406. treated in the same way by all implementations of \MF. However, users
  13407. need the ability to refer to other files in their environment, especially
  13408. when responding to error messages concerning unopenable files; therefore
  13409. we want to let them use the syntax that appears in their favorite
  13410. operating system.
  13411. @ \MF\ uses the same conventions that have proved to be satisfactory for
  13412. \TeX. In order to isolate the system-dependent aspects of file names, the
  13413. @^system dependencies@>
  13414. system-independent parts of \MF\ are expressed in terms
  13415. of three system-dependent
  13416. procedures called |begin_name|, |more_name|, and |end_name|. In
  13417. essence, if the user-specified characters of the file name are $c_1\ldots c_n$,
  13418. the system-independent driver program does the operations
  13419. $$|begin_name|;\,|more_name|(c_1);\,\ldots\,;|more_name|(c_n);
  13420. \,|end_name|.$$
  13421. These three procedures communicate with each other via global variables.
  13422. Afterwards the file name will appear in the string pool as three strings
  13423. called |cur_name|\penalty10000\hskip-.05em,
  13424. |cur_area|, and |cur_ext|; the latter two are null (i.e.,
  13425. |""|), unless they were explicitly specified by the user.
  13426. Actually the situation is slightly more complicated, because \MF\ needs
  13427. to know when the file name ends. The |more_name| routine is a function
  13428. (with side effects) that returns |true| on the calls |more_name|$(c_1)$,
  13429. \dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$
  13430. returns |false|; or, it returns |true| and $c_n$ is the last character
  13431. on the current input line. In other words,
  13432. |more_name| is supposed to return |true| unless it is sure that the
  13433. file name has been completely scanned; and |end_name| is supposed to be able
  13434. to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of
  13435. whether $|more_name|(c_n)$ returned |true| or |false|.
  13436. @<Glob...@>=
  13437. @!cur_name:str_number; {name of file just scanned}
  13438. @!cur_area:str_number; {file area just scanned, or \.{""}}
  13439. @!cur_ext:str_number; {file extension just scanned, or \.{""}}
  13440. @ The file names we shall deal with for illustrative purposes have the
  13441. following structure:  If the name contains `\.>' or `\.:', the file area
  13442. consists of all characters up to and including the final such character;
  13443. otherwise the file area is null.  If the remaining file name contains
  13444. `\..', the file extension consists of all such characters from the first
  13445. remaining `\..' to the end, otherwise the file extension is null.
  13446. @^system dependencies@>
  13447. We can scan such file names easily by using two global variables that keep track
  13448. of the occurrences of area and extension delimiters:
  13449. @<Glob...@>=
  13450. @!area_delimiter:pool_pointer; {the most recent `\.>' or `\.:', if any}
  13451. @!ext_delimiter:pool_pointer; {the relevant `\..', if any}
  13452. @ Input files that can't be found in the user's area may appear in a standard
  13453. system area called |MF_area|.
  13454. This system area name will, of course, vary from place to place.
  13455. @^system dependencies@>
  13456. @d MF_area=="MFinputs:"
  13457. @.MFinputs@>
  13458. @ Here now is the first of the system-dependent routines for file name scanning.
  13459. @^system dependencies@>
  13460. @p procedure begin_name;
  13461. begin area_delimiter:=0; ext_delimiter:=0;
  13462. @ And here's the second.
  13463. @^system dependencies@>
  13464. @p function more_name(@!c:ASCII_code):boolean;
  13465. begin if c=" " then more_name:=false
  13466. else  begin if (c=">")or(c=":") then
  13467.     begin area_delimiter:=pool_ptr; ext_delimiter:=0;
  13468.     end
  13469.   else if (c=".")and(ext_delimiter=0) then ext_delimiter:=pool_ptr;
  13470.   str_room(1); append_char(c); {contribute |c| to the current string}
  13471.   more_name:=true;
  13472.   end;
  13473. @ The third.
  13474. @^system dependencies@>
  13475. @p procedure end_name;
  13476. begin if str_ptr+3>max_str_ptr then
  13477.   begin if str_ptr+3>max_strings then
  13478.     overflow("number of strings",max_strings-init_str_ptr);
  13479. @:METAFONT capacity exceeded number of strings}{\quad number of strings@>
  13480.   max_str_ptr:=str_ptr+3;
  13481.   end;
  13482. if area_delimiter=0 then cur_area:=""
  13483. else  begin cur_area:=str_ptr; incr(str_ptr);
  13484.   str_start[str_ptr]:=area_delimiter+1;
  13485.   end;
  13486. if ext_delimiter=0 then
  13487.   begin cur_ext:=""; cur_name:=make_string;
  13488.   end
  13489. else  begin cur_name:=str_ptr; incr(str_ptr);
  13490.   str_start[str_ptr]:=ext_delimiter; cur_ext:=make_string;
  13491.   end;
  13492. @ Conversely, here is a routine that takes three strings and prints a file
  13493. name that might have produced them. (The routine is system dependent, because
  13494. some operating systems put the file area last instead of first.)
  13495. @^system dependencies@>
  13496. @<Basic printing...@>=
  13497. procedure print_file_name(@!n,@!a,@!e:integer);
  13498. begin slow_print(a); slow_print(n); slow_print(e);
  13499. @ Another system-dependent routine is needed to convert three internal
  13500. \MF\ strings
  13501. to the |name_of_file| value that is used to open files. The present code
  13502. allows both lowercase and uppercase letters in the file name.
  13503. @^system dependencies@>
  13504. @d append_to_name(#)==begin c:=#; incr(k);
  13505.   if k<=file_name_size then name_of_file[k]:=xchr[c];
  13506.   end
  13507. @p procedure pack_file_name(@!n,@!a,@!e:str_number);
  13508. var @!k:integer; {number of positions filled in |name_of_file|}
  13509. @!c: ASCII_code; {character being packed}
  13510. @!j:pool_pointer; {index into |str_pool|}
  13511. begin k:=0;
  13512. for j:=str_start[a] to str_start[a+1]-1 do append_to_name(so(str_pool[j]));
  13513. for j:=str_start[n] to str_start[n+1]-1 do append_to_name(so(str_pool[j]));
  13514. for j:=str_start[e] to str_start[e+1]-1 do append_to_name(so(str_pool[j]));
  13515. if k<=file_name_size then name_length:=k@+else name_length:=file_name_size;
  13516. for k:=name_length+1 to file_name_size do name_of_file[k]:=' ';
  13517. @ A messier routine is also needed, since base file names must be scanned
  13518. before \MF's string mechanism has been initialized. We shall use the
  13519. global variable |MF_base_default| to supply the text for default system areas
  13520. and extensions related to base files.
  13521. @^system dependencies@>
  13522. @d base_default_length=18 {length of the |MF_base_default| string}
  13523. @d base_area_length=8 {length of its area part}
  13524. @d base_ext_length=5 {length of its `\.{.base}' part}
  13525. @d base_extension=".base" {the extension, as a \.{WEB} constant}
  13526. @<Glob...@>=
  13527. @!MF_base_default:packed array[1..base_default_length] of char;
  13528. @ @<Set init...@>=
  13529. MF_base_default:='MFbases:plain.base';
  13530. @.MFbases@>
  13531. @.plain@>
  13532. @^system dependencies@>
  13533. @ @<Check the ``constant'' values for consistency@>=
  13534. if base_default_length>file_name_size then bad:=41;
  13535. @ Here is the messy routine that was just mentioned. It sets |name_of_file|
  13536. from the first |n| characters of |MF_base_default|, followed by
  13537. |buffer[a..b]|, followed by the last |base_ext_length| characters of
  13538. |MF_base_default|.
  13539. We dare not give error messages here, since \MF\ calls this routine before
  13540. the |error| routine is ready to roll. Instead, we simply drop excess characters,
  13541. since the error will be detected in another way when a strange file name
  13542. isn't found.
  13543. @^system dependencies@>
  13544. @p procedure pack_buffered_name(@!n:small_number;@!a,@!b:integer);
  13545. var @!k:integer; {number of positions filled in |name_of_file|}
  13546. @!c: ASCII_code; {character being packed}
  13547. @!j:integer; {index into |buffer| or |MF_base_default|}
  13548. begin if n+b-a+1+base_ext_length>file_name_size then
  13549.   b:=a+file_name_size-n-1-base_ext_length;
  13550. k:=0;
  13551. for j:=1 to n do append_to_name(xord[MF_base_default[j]]);
  13552. for j:=a to b do append_to_name(buffer[j]);
  13553. for j:=base_default_length-base_ext_length+1 to base_default_length do
  13554.   append_to_name(xord[MF_base_default[j]]);
  13555. if k<=file_name_size then name_length:=k@+else name_length:=file_name_size;
  13556. for k:=name_length+1 to file_name_size do name_of_file[k]:=' ';
  13557. @ Here is the only place we use |pack_buffered_name|. This part of the program
  13558. becomes active when a ``virgin'' \MF\ is trying to get going, just after
  13559. the preliminary initialization, or when the user is substituting another
  13560. base file by typing `\.\&' after the initial `\.{**}' prompt.  The buffer
  13561. contains the first line of input in |buffer[loc..(last-1)]|, where
  13562. |loc<last| and |buffer[loc]<>" "|.
  13563. @<Declare the function called |open_base_file|@>=
  13564. function open_base_file:boolean;
  13565. label found,exit;
  13566. var @!j:0..buf_size; {the first space after the file name}
  13567. begin j:=loc;
  13568. if buffer[loc]="&" then
  13569.   begin incr(loc); j:=loc; buffer[last]:=" ";
  13570.   while buffer[j]<>" " do incr(j);
  13571.   pack_buffered_name(0,loc,j-1); {try first without the system file area}
  13572.   if w_open_in(base_file) then goto found;
  13573.   pack_buffered_name(base_area_length,loc,j-1);
  13574.     {now try the system base file area}
  13575.   if w_open_in(base_file) then goto found;
  13576.   wake_up_terminal;
  13577.   wterm_ln('Sorry, I can''t find that base;',' will try PLAIN.');
  13578. @.Sorry, I can't find...@>
  13579.   update_terminal;
  13580.   end;
  13581.   {now pull out all the stops: try for the system \.{plain} file}
  13582. pack_buffered_name(base_default_length-base_ext_length,1,0);
  13583. if not w_open_in(base_file) then
  13584.   begin wake_up_terminal;
  13585.   wterm_ln('I can''t find the PLAIN base file!');
  13586. @.I can't find PLAIN...@>
  13587. @.plain@>
  13588.   open_base_file:=false; return;
  13589.   end;
  13590. found:loc:=j; open_base_file:=true;
  13591. exit:end;
  13592. @ Operating systems often make it possible to determine the exact name (and
  13593. possible version number) of a file that has been opened. The following routine,
  13594. which simply makes a \MF\ string from the value of |name_of_file|, should
  13595. ideally be changed to deduce the full name of file~|f|, which is the file
  13596. most recently opened, if it is possible to do this in a \PASCAL\ program.
  13597. @^system dependencies@>
  13598. This routine might be called after string memory has overflowed, hence
  13599. we dare not use `|str_room|'.
  13600. @p function make_name_string:str_number;
  13601. var @!k:1..file_name_size; {index into |name_of_file|}
  13602. begin if (pool_ptr+name_length>pool_size)or(str_ptr=max_strings) then
  13603.   make_name_string:="?"
  13604. else  begin for k:=1 to name_length do append_char(xord[name_of_file[k]]);
  13605.   make_name_string:=make_string;
  13606.   end;
  13607. function a_make_name_string(var @!f:alpha_file):str_number;
  13608. begin a_make_name_string:=make_name_string;
  13609. function b_make_name_string(var @!f:byte_file):str_number;
  13610. begin b_make_name_string:=make_name_string;
  13611. function w_make_name_string(var @!f:word_file):str_number;
  13612. begin w_make_name_string:=make_name_string;
  13613. @ Now let's consider the ``driver''
  13614. routines by which \MF\ deals with file names
  13615. in a system-independent manner.  First comes a procedure that looks for a
  13616. file name in the input by taking the information from the input buffer.
  13617. (We can't use |get_next|, because the conversion to tokens would
  13618. destroy necessary information.)
  13619. This procedure doesn't allow semicolons or percent signs to be part of
  13620. file names, because of other conventions of \MF. The manual doesn't
  13621. use semicolons or percents immediately after file names, but some users
  13622. no doubt will find it natural to do so; therefore system-dependent
  13623. changes to allow such characters in file names should probably
  13624. be made with reluctance, and only when an entire file name that
  13625. includes special characters is ``quoted'' somehow.
  13626. @^system dependencies@>
  13627. @p procedure scan_file_name;
  13628. label done;
  13629. begin begin_name;
  13630. while buffer[loc]=" " do incr(loc);
  13631. loop@+begin if (buffer[loc]=";")or(buffer[loc]="%") then goto done;
  13632.   if not more_name(buffer[loc]) then goto done;
  13633.   incr(loc);
  13634.   end;
  13635. done: end_name;
  13636. @ The global variable |job_name| contains the file name that was first
  13637. \&{input} by the user. This name is extended by `\.{.log}' and `\.{.gf}' and
  13638. `\.{.base}' and `\.{.tfm}' in the names of \MF's output files.
  13639. @<Glob...@>=
  13640. @!job_name:str_number; {principal file name}
  13641. @!log_opened:boolean; {has the transcript file been opened?}
  13642. @!log_name:str_number; {full name of the log file}
  13643. @ Initially |job_name=0|; it becomes nonzero as soon as the true name is known.
  13644. We have |job_name=0| if and only if the `\.{log}' file has not been opened,
  13645. except of course for a short time just after |job_name| has become nonzero.
  13646. @<Initialize the output...@>=job_name:=0; log_opened:=false;
  13647. @ Here is a routine that manufactures the output file names, assuming that
  13648. |job_name<>0|. It ignores and changes the current settings of |cur_area|
  13649. and |cur_ext|.
  13650. @d pack_cur_name==pack_file_name(cur_name,cur_area,cur_ext)
  13651. @p procedure pack_job_name(@!s:str_number); {|s = ".log"|, |".gf"|, or
  13652.   |base_extension|}
  13653. begin cur_area:=""; cur_ext:=s;
  13654. cur_name:=job_name; pack_cur_name;
  13655. @ Actually the main output file extension is usually something like
  13656. |".300gf"| instead of just |".gf"|; the additional number indicates the
  13657. resolution in pixels per inch, based on the setting of |hppp| when
  13658. the file is opened.
  13659. @<Glob...@>=
  13660. @!gf_ext:str_number; {default extension for the output file}
  13661. @ If some trouble arises when \MF\ tries to open a file, the following
  13662. routine calls upon the user to supply another file name. Parameter~|s|
  13663. is used in the error message to identify the type of file; parameter~|e|
  13664. is the default extension if none is given. Upon exit from the routine,
  13665. variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are
  13666. ready for another attempt at file opening.
  13667. @p procedure prompt_file_name(@!s,@!e:str_number);
  13668. label done;
  13669. var @!k:0..buf_size; {index into |buffer|}
  13670. begin if interaction=scroll_mode then wake_up_terminal;
  13671. if s="input file name" then print_err("I can't find file `")
  13672. @.I can't find file x@>
  13673. else print_err("I can't write on file `");
  13674. @.I can't write on file x@>
  13675. print_file_name(cur_name,cur_area,cur_ext); print("'.");
  13676. if e=".mf" then show_context;
  13677. print_nl("Please type another "); print(s);
  13678. @.Please type...@>
  13679. if interaction<scroll_mode then
  13680.   fatal_error("*** (job aborted, file error in nonstop mode)");
  13681. @.job aborted, file error...@>
  13682. clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>;
  13683. if cur_ext="" then cur_ext:=e;
  13684. pack_cur_name;
  13685. @ @<Scan file name in the buffer@>=
  13686. begin begin_name; k:=first;
  13687. while (buffer[k]=" ")and(k<last) do incr(k);
  13688. loop@+  begin if k=last then goto done;
  13689.   if not more_name(buffer[k]) then goto done;
  13690.   incr(k);
  13691.   end;
  13692. done:end_name;
  13693. @ The |open_log_file| routine is used to open the transcript file and to help
  13694. it catch up to what has previously been printed on the terminal.
  13695. @p procedure open_log_file;
  13696. var @!old_setting:0..max_selector; {previous |selector| setting}
  13697. @!k:0..buf_size; {index into |months| and |buffer|}
  13698. @!l:0..buf_size; {end of first input line}
  13699. @!m:integer; {the current month}
  13700. @!months:packed array [1..36] of char; {abbreviations of month names}
  13701. begin old_setting:=selector;
  13702. if job_name=0 then job_name:="mfput";
  13703. pack_job_name(".log");
  13704. while not a_open_out(log_file) do @<Try to get a different log file name@>;
  13705. log_name:=a_make_name_string(log_file);
  13706. selector:=log_only; log_opened:=true;
  13707. @<Print the banner line, including the date and time@>;
  13708. input_stack[input_ptr]:=cur_input; {make sure bottom level is in memory}
  13709. print_nl("**");
  13710. @.**@>
  13711. l:=input_stack[0].limit_field-1; {last position of first line}
  13712. for k:=1 to l do print(buffer[k]);
  13713. print_ln; {now the transcript file contains the first line of input}
  13714. selector:=old_setting+2; {|log_only| or |term_and_log|}
  13715. @ Sometimes |open_log_file| is called at awkward moments when \MF\ is
  13716. unable to print error messages or even to |show_context|.
  13717. The |prompt_file_name| routine can result in a |fatal_error|, but the |error|
  13718. routine will not be invoked because |log_opened| will be false.
  13719. The normal idea of |batch_mode| is that nothing at all should be written
  13720. on the terminal. However, in the unusual case that
  13721. no log file could be opened, we make an exception and allow
  13722. an explanatory message to be seen.
  13723. Incidentally, the program always refers to the log file as a `\.{transcript
  13724. file}', because some systems cannot use the extension `\.{.log}' for
  13725. this file.
  13726. @<Try to get a different log file name@>=
  13727. begin selector:=term_only;
  13728. prompt_file_name("transcript file name",".log");
  13729. @ @<Print the banner...@>=
  13730. begin wlog(banner);
  13731. slow_print(base_ident); print("  ");
  13732. print_int(round_unscaled(internal[day])); print_char(" ");
  13733. months:='JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
  13734. m:=round_unscaled(internal[month]);
  13735. for k:=3*m-2 to 3*m do wlog(months[k]);
  13736. print_char(" "); print_int(round_unscaled(internal[year])); print_char(" ");
  13737. m:=round_unscaled(internal[time]);
  13738. print_dd(m div 60); print_char(":"); print_dd(m mod 60);
  13739. @ Here's an example of how these file-name-parsing routines work in practice.
  13740. We shall use the macro |set_output_file_name| when it is time to
  13741. crank up the output file.
  13742. @d set_output_file_name==
  13743.   begin if job_name=0 then open_log_file;
  13744.   pack_job_name(gf_ext);
  13745.   while not b_open_out(gf_file) do
  13746.     prompt_file_name("file name for output",gf_ext);
  13747.   output_file_name:=b_make_name_string(gf_file);
  13748.   end
  13749. @<Glob...@>=
  13750. @!gf_file: byte_file; {the generic font output goes here}
  13751. @!output_file_name: str_number; {full name of the output file}
  13752. @ @<Initialize the output...@>=output_file_name:=0;
  13753. @ Let's turn now to the procedure that is used to initiate file reading
  13754. when an `\.{input}' command is being processed.
  13755. @p procedure start_input; {\MF\ will \.{input} something}
  13756. label done;
  13757. begin @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>;
  13758. if cur_ext="" then cur_ext:=".mf";
  13759. pack_cur_name;
  13760. loop@+  begin begin_file_reading; {set up |cur_file| and new level of input}
  13761.   if a_open_in(cur_file) then goto done;
  13762.   if cur_area="" then
  13763.     begin pack_file_name(cur_name,MF_area,cur_ext);
  13764.     if a_open_in(cur_file) then goto done;
  13765.     end;
  13766.   end_file_reading; {remove the level that didn't work}
  13767.   prompt_file_name("input file name",".mf");
  13768.   end;
  13769. done: name:=a_make_name_string(cur_file); str_ref[cur_name]:=max_str_ref;
  13770. if job_name=0 then
  13771.   begin job_name:=cur_name; open_log_file;
  13772.   end; {|open_log_file| doesn't |show_context|, so |limit|
  13773.     and |loc| needn't be set to meaningful values yet}
  13774. if term_offset+length(name)>max_print_line-2 then print_ln
  13775. else if (term_offset>0)or(file_offset>0) then print_char(" ");
  13776. print_char("("); incr(open_parens); slow_print(name); update_terminal;
  13777. if name=str_ptr-1 then {we can conserve string pool space now}
  13778.   begin flush_string(name); name:=cur_name;
  13779.   end;
  13780. @<Read the first line of the new file@>;
  13781. @ Here we have to remember to tell the |input_ln| routine not to
  13782. start with a |get|. If the file is empty, it is considered to
  13783. contain a single blank line.
  13784. @^system dependencies@>
  13785. @<Read the first line...@>=
  13786. begin line:=1;
  13787. if input_ln(cur_file,false) then do_nothing;
  13788. firm_up_the_line;
  13789. buffer[limit]:="%"; first:=limit+1; loc:=start;
  13790. @ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>=
  13791. while token_state and(loc=null) do end_token_list;
  13792. if token_state then
  13793.   begin print_err("File names can't appear within macros");
  13794. @.File names can't...@>
  13795.   help3("Sorry...I've converted what follows to tokens,")@/
  13796.     ("possibly garbaging the name you gave.")@/
  13797.     ("Please delete the tokens and insert the name again.");@/
  13798.   error;
  13799.   end;
  13800. if file_state then scan_file_name
  13801. else  begin cur_name:=""; cur_ext:=""; cur_area:="";
  13802.   end
  13803. @* \[39] Introduction to the parsing routines.
  13804. We come now to the central nervous system that sparks many of \MF's activities.
  13805. By evaluating expressions, from their primary constituents to ever larger
  13806. subexpressions, \MF\ builds the structures that ultimately define fonts of type.
  13807. Four mutually recursive subroutines are involved in this process: We call them
  13808. $$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|,
  13809. and |scan_expression|.}$$
  13810. @^recursion@>
  13811. Each of them is parameterless and begins with the first token to be scanned
  13812. already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution,
  13813. the value of the primary or secondary or tertiary or expression that was
  13814. found will appear in the global variables |cur_type| and |cur_exp|. The
  13815. token following the expression will be represented in |cur_cmd|, |cur_mod|,
  13816. and |cur_sym|.
  13817. Technically speaking, the parsing algorithms are ``LL(1),'' more or less;
  13818. backup mechanisms have been added in order to provide reasonable error
  13819. recovery.
  13820. @<Glob...@>=
  13821. @!cur_type:small_number; {the type of the expression just found}
  13822. @!cur_exp:integer; {the value of the expression just found}
  13823. @ @<Set init...@>=
  13824. cur_exp:=0;
  13825. @ Many different kinds of expressions are possible, so it is wise to have
  13826. precise descriptions of what |cur_type| and |cur_exp| mean in all cases:
  13827. \smallskip\hang
  13828. |cur_type=vacuous| means that this expression didn't turn out to have a
  13829. value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup}
  13830. construction in which there was no expression before the \&{endgroup}.
  13831. In this case |cur_exp| has some irrelevant value.
  13832. \smallskip\hang
  13833. |cur_type=boolean_type| means that |cur_exp| is either |true_code|
  13834. or |false_code|.
  13835. \smallskip\hang
  13836. |cur_type=unknown_boolean| means that |cur_exp| points to a capsule
  13837. node that is in the ring of variables equivalent
  13838. to at least one undefined boolean variable.
  13839. \smallskip\hang
  13840. |cur_type=string_type| means that |cur_exp| is a string number (i.e., an
  13841. integer in the range |0<=cur_exp<str_ptr|). That string's reference count
  13842. includes this particular reference.
  13843. \smallskip\hang
  13844. |cur_type=unknown_string| means that |cur_exp| points to a capsule
  13845. node that is in the ring of variables equivalent
  13846. to at least one undefined string variable.
  13847. \smallskip\hang
  13848. |cur_type=pen_type| means that |cur_exp| points to a pen header node. This
  13849. node contains a reference count, which takes account of this particular
  13850. reference.
  13851. \smallskip\hang
  13852. |cur_type=unknown_pen| means that |cur_exp| points to a capsule
  13853. node that is in the ring of variables equivalent
  13854. to at least one undefined pen variable.
  13855. \smallskip\hang
  13856. |cur_type=future_pen| means that |cur_exp| points to a knot list that
  13857. should eventually be made into a pen. Nobody else points to this particular
  13858. knot list. The |future_pen| option occurs only as an output of |scan_primary|
  13859. and |scan_secondary|, not as an output of |scan_tertiary| or |scan_expression|.
  13860. \smallskip\hang
  13861. |cur_type=path_type| means that |cur_exp| points to a the first node of
  13862. a path; nobody else points to this particular path. The control points of
  13863. the path will have been chosen.
  13864. \smallskip\hang
  13865. |cur_type=unknown_path| means that |cur_exp| points to a capsule
  13866. node that is in the ring of variables equivalent
  13867. to at least one undefined path variable.
  13868. \smallskip\hang
  13869. |cur_type=picture_type| means that |cur_exp| points to an edges header node.
  13870. Nobody else points to this particular set of edges.
  13871. \smallskip\hang
  13872. |cur_type=unknown_picture| means that |cur_exp| points to a capsule
  13873. node that is in the ring of variables equivalent
  13874. to at least one undefined picture variable.
  13875. \smallskip\hang
  13876. |cur_type=transform_type| means that |cur_exp| points to a |transform_type|
  13877. capsule node. The |value| part of this capsule
  13878. points to a transform node that contains six numeric values,
  13879. each of which is |independent|, |dependent|, |proto_dependent|, or |known|.
  13880. \smallskip\hang
  13881. |cur_type=pair_type| means that |cur_exp| points to a capsule
  13882. node whose type is |pair_type|. The |value| part of this capsule
  13883. points to a pair node that contains two numeric values,
  13884. each of which is |independent|, |dependent|, |proto_dependent|, or |known|.
  13885. \smallskip\hang
  13886. |cur_type=known| means that |cur_exp| is a |scaled| value.
  13887. \smallskip\hang
  13888. |cur_type=dependent| means that |cur_exp| points to a capsule node whose type
  13889. is |dependent|. The |dep_list| field in this capsule points to the associated
  13890. dependency list.
  13891. \smallskip\hang
  13892. |cur_type=proto_dependent| means that |cur_exp| points to a |proto_dependent|
  13893. capsule node . The |dep_list| field in this capsule
  13894. points to the associated dependency list.
  13895. \smallskip\hang
  13896. |cur_type=independent| means that |cur_exp| points to a capsule node
  13897. whose type is |independent|. This somewhat unusual case can arise, for
  13898. example, in the expression
  13899. `$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'.
  13900. \smallskip\hang
  13901. |cur_type=token_list| means that |cur_exp| points to a linked list of
  13902. tokens. This case arises only on the left-hand side of an assignment
  13903. (`\.{:=}') operation, under very special circumstances.
  13904. \smallskip\noindent
  13905. The possible settings of |cur_type| have been listed here in increasing
  13906. numerical order. Notice that |cur_type| will never be |numeric_type| or
  13907. |suffixed_macro| or |unsuffixed_macro|, although variables of those types
  13908. are allowed.  Conversely, \MF\ has no variables of type |vacuous| or
  13909. |token_list|.
  13910. @ Capsules are two-word nodes that have a similar meaning
  13911. to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|
  13912. and |link<=void|; and their |type| field is one of the possibilities for
  13913. |cur_type| listed above.
  13914. The |value| field of a capsule is, in most cases, the value that
  13915. corresponds to its |type|, as |cur_exp| corresponds to |cur_type|.
  13916. However, when |cur_exp| would point to a capsule,
  13917. no extra layer of indirection is present; the |value|
  13918. field is what would have been called |value(cur_exp)| if it had not been
  13919. encapsulated.  Furthermore, if the type is |dependent| or
  13920. |proto_dependent|, the |value| field of a capsule is replaced by
  13921. |dep_list| and |prev_dep| fields, since dependency lists in capsules are
  13922. always part of the general |dep_list| structure.
  13923. The |get_x_next| routine is careful not to change the values of |cur_type|
  13924. and |cur_exp| when it gets an expanded token. However, |get_x_next| might
  13925. call a macro, which might parse an expression, which might execute lots of
  13926. commands in a group; hence it's possible that |cur_type| might change
  13927. from, say, |unknown_boolean| to |boolean_type|, or from |dependent| to
  13928. |known| or |independent|, during the time |get_x_next| is called. The
  13929. programs below are careful to stash sensitive intermediate results in
  13930. capsules, so that \MF's generality doesn't cause trouble.
  13931. Here's a procedure that illustrates these conventions. It takes
  13932. the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$
  13933. and stashes them away in a
  13934. capsule. It is not used when |cur_type=token_list|.
  13935. After the operation, |cur_type=vacuous|; hence there is no need to
  13936. copy path lists or to update reference counts, etc.
  13937. The special link |void| is put on the capsule returned by
  13938. |stash_cur_exp|, because this procedure is used to store macro parameters
  13939. that must be easily distinguishable from token lists.
  13940. @<Declare the stashing/unstashing routines@>=
  13941. function stash_cur_exp:pointer;
  13942. var @!p:pointer; {the capsule that will be returned}
  13943. begin case cur_type of
  13944. unknown_types,transform_type,pair_type,dependent,proto_dependent,
  13945.   independent:p:=cur_exp;
  13946. othercases begin  p:=get_node(value_node_size); name_type(p):=capsule;
  13947.   type(p):=cur_type; value(p):=cur_exp;
  13948.   end
  13949. endcases;@/
  13950. cur_type:=vacuous; link(p):=void; stash_cur_exp:=p;
  13951. @ The inverse of |stash_cur_exp| is the following procedure, which
  13952. deletes an unnecessary capsule and puts its contents into |cur_type|
  13953. and |cur_exp|.
  13954. The program steps of \MF\ can be divided into two categories: those in
  13955. which |cur_type| and |cur_exp| are ``alive'' and those in which they are
  13956. ``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant
  13957. information or not. It's important not to ignore them when they're alive,
  13958. and it's important not to pay attention to them when they're dead.
  13959. There's also an intermediate category: If |cur_type=vacuous|, then
  13960. |cur_exp| is irrelevant, hence we can proceed without caring if |cur_type|
  13961. and |cur_exp| are alive or dead. In such cases we say that |cur_type|
  13962. and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next|
  13963. only when they are alive or dormant.
  13964. The \\{stash} procedure above assumes that |cur_type| and |cur_exp|
  13965. are alive or dormant. The \\{unstash} procedure assumes that they are
  13966. dead or dormant; it resuscitates them.
  13967. @<Declare the stashing/unstashing...@>=
  13968. procedure unstash_cur_exp(@!p:pointer);
  13969. begin cur_type:=type(p);
  13970. case cur_type of
  13971. unknown_types,transform_type,pair_type,dependent,proto_dependent,
  13972.   independent: cur_exp:=p;
  13973. othercases begin cur_exp:=value(p);
  13974.   free_node(p,value_node_size);
  13975.   end
  13976. endcases;@/
  13977. @ The following procedure prints the values of expressions in an
  13978. abbreviated format. If its first parameter |p| is null, the value of
  13979. |(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule
  13980. containing the desired value. The second parameter controls the amount of
  13981. output. If it is~0, dependency lists will be abbreviated to
  13982. `\.{linearform}' unless they consist of a single term.  If it is greater
  13983. than~1, complicated structures (pens, pictures, and paths) will be displayed
  13984. in full.
  13985. @<Declare subroutines for printing expressions@>=
  13986. @t\4@>@<Declare the procedure called |print_dp|@>@;
  13987. @t\4@>@<Declare the stashing/unstashing routines@>@;
  13988. procedure print_exp(@!p:pointer;@!verbosity:small_number);
  13989. var @!restore_cur_exp:boolean; {should |cur_exp| be restored?}
  13990. @!t:small_number; {the type of the expression}
  13991. @!v:integer; {the value of the expression}
  13992. @!q:pointer; {a big node being displayed}
  13993. begin if p<>null then restore_cur_exp:=false
  13994. else  begin p:=stash_cur_exp; restore_cur_exp:=true;
  13995.   end;
  13996. t:=type(p);
  13997. if t<dependent then v:=value(p)@+else if t<independent then v:=dep_list(p);
  13998. @<Print an abbreviated value of |v| with format depending on |t|@>;
  13999. if restore_cur_exp then unstash_cur_exp(p);
  14000. @ @<Print an abbreviated value of |v| with format depending on |t|@>=
  14001. case t of
  14002. vacuous:print("vacuous");
  14003. boolean_type:if v=true_code then print("true")@+else print("false");
  14004. unknown_types,numeric_type:@<Display a variable
  14005.   that's been declared but not defined@>;
  14006. string_type:begin print_char(""""); slow_print(v); print_char("""");
  14007.   end;
  14008. pen_type,future_pen,path_type,picture_type:@<Display a complex type@>;
  14009. transform_type,pair_type:if v=null then print_type(t)
  14010.   else @<Display a big node@>;
  14011. known:print_scaled(v);
  14012. dependent,proto_dependent:print_dp(t,v,verbosity);
  14013. independent:print_variable_name(p);
  14014. othercases confusion("exp")
  14015. @:this can't happen exp}{\quad exp@>
  14016. endcases
  14017. @ @<Display a big node@>=
  14018. begin print_char("("); q:=v+big_node_size[t];
  14019. repeat if type(v)=known then print_scaled(value(v))
  14020. else if type(v)=independent then print_variable_name(v)
  14021. else print_dp(type(v),dep_list(v),verbosity);
  14022. v:=v+2;
  14023. if v<>q then print_char(",");
  14024. until v=q;
  14025. print_char(")");
  14026. @ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely
  14027. in the log file only, unless the user has given a positive value to
  14028. \\{tracingonline}.
  14029. @<Display a complex type@>=
  14030. if verbosity<=1 then print_type(t)
  14031. else  begin if selector=term_and_log then
  14032.    if internal[tracing_online]<=0 then
  14033.     begin selector:=term_only;
  14034.     print_type(t); print(" (see the transcript file)");
  14035.     selector:=term_and_log;
  14036.     end;
  14037.   case t of
  14038.   pen_type:print_pen(v,"",false);
  14039.   future_pen:print_path(v," (future pen)",false);
  14040.   path_type:print_path(v,"",false);
  14041.   picture_type:begin cur_edges:=v; print_edges("",false,0,0);
  14042.     end;
  14043.   end; {there are no other cases}
  14044.   end
  14045. @ @<Declare the procedure called |print_dp|@>=
  14046. procedure print_dp(@!t:small_number;@!p:pointer;@!verbosity:small_number);
  14047. var @!q:pointer; {the node following |p|}
  14048. begin q:=link(p);
  14049. if (info(q)=null) or (verbosity>0) then print_dependency(p,t)
  14050. else print("linearform");
  14051. @ The displayed name of a variable in a ring will not be a capsule unless
  14052. the ring consists entirely of capsules.
  14053. @<Display a variable that's been declared but not defined@>=
  14054. begin print_type(t);
  14055. if v<>null then
  14056.   begin print_char(" ");
  14057.   while (name_type(v)=capsule) and (v<>p) do v:=value(v);
  14058.   print_variable_name(v);
  14059.   end;
  14060. @ When errors are detected during parsing, it is often helpful to
  14061. display an expression just above the error message, using |exp_err|
  14062. or |disp_err| instead of |print_err|.
  14063. @d exp_err(#)==disp_err(null,#) {displays the current expression}
  14064. @<Declare subroutines for printing expressions@>=
  14065. procedure disp_err(@!p:pointer;@!s:str_number);
  14066. begin if interaction=error_stop_mode then wake_up_terminal;
  14067. print_nl(">> ");
  14068. @.>>@>
  14069. print_exp(p,1); {``medium verbose'' printing of the expression}
  14070. if s<>"" then
  14071.   begin print_nl("! "); print(s);
  14072. @.!\relax@>
  14073.   end;
  14074. @ If |cur_type| and |cur_exp| contain relevant information that should
  14075. be recycled, we will use the following procedure, which changes |cur_type|
  14076. to |known| and stores a given value in |cur_exp|. We can think of |cur_type|
  14077. and |cur_exp| as either alive or dormant after this has been done,
  14078. because |cur_exp| will not contain a pointer value.
  14079. @<Declare the procedure called |flush_cur_exp|@>=
  14080. procedure flush_cur_exp(@!v:scaled);
  14081. begin case cur_type of
  14082. unknown_types,transform_type,pair_type,@|dependent,proto_dependent,independent:
  14083.   begin recycle_value(cur_exp); free_node(cur_exp,value_node_size);
  14084.   end;
  14085. pen_type: delete_pen_ref(cur_exp);
  14086. string_type:delete_str_ref(cur_exp);
  14087. future_pen,path_type: toss_knot_list(cur_exp);
  14088. picture_type:toss_edges(cur_exp);
  14089. othercases do_nothing
  14090. endcases;@/
  14091. cur_type:=known; cur_exp:=v;
  14092. @ There's a much more general procedure that is capable of releasing
  14093. the storage associated with any two-word value packet.
  14094. @<Declare the recycling subroutines@>=
  14095. procedure recycle_value(@!p:pointer);
  14096. label done;
  14097. var @!t:small_number; {a type code}
  14098. @!v:integer; {a value}
  14099. @!vv:integer; {another value}
  14100. @!q,@!r,@!s,@!pp:pointer; {link manipulation registers}
  14101. begin t:=type(p);
  14102. if t<dependent then v:=value(p);
  14103. case t of
  14104. undefined,vacuous,boolean_type,known,numeric_type:do_nothing;
  14105. unknown_types:ring_delete(p);
  14106. string_type:delete_str_ref(v);
  14107. pen_type:delete_pen_ref(v);
  14108. path_type,future_pen:toss_knot_list(v);
  14109. picture_type:toss_edges(v);
  14110. pair_type,transform_type:@<Recycle a big node@>;
  14111. dependent,proto_dependent:@<Recycle a dependency list@>;
  14112. independent:@<Recycle an independent variable@>;
  14113. token_list,structured:confusion("recycle");
  14114. @:this can't happen recycle}{\quad recycle@>
  14115. unsuffixed_macro,suffixed_macro:delete_mac_ref(value(p));
  14116. end; {there are no other cases}
  14117. type(p):=undefined;
  14118. @ @<Recycle a big node@>=
  14119. if v<>null then
  14120.   begin q:=v+big_node_size[t];
  14121.   repeat q:=q-2; recycle_value(q);
  14122.   until q=v;
  14123.   free_node(v,big_node_size[t]);
  14124.   end
  14125. @ @<Recycle a dependency list@>=
  14126. begin q:=dep_list(p);
  14127. while info(q)<>null do q:=link(q);
  14128. link(prev_dep(p)):=link(q);
  14129. prev_dep(link(q)):=prev_dep(p);
  14130. link(q):=null; flush_node_list(dep_list(p));
  14131. @ When an independent variable disappears, it simply fades away, unless
  14132. something depends on it. In the latter case, a dependent variable whose
  14133. coefficient of dependence is maximal will take its place.
  14134. The relevant algorithm is due to Ignacio~A. Zabala, who implemented it
  14135. as part of his Ph.D. thesis (Stanford University, December 1982).
  14136. @^Zabala Salelles, Ignacio Andres@>
  14137. For example, suppose that variable $x$ is being recycled, and that the
  14138. only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case
  14139. we want to make $y$ independent and $z=.5y-.5a+b$; no other variables
  14140. will depend on~$y$. If $\\{tracingequations}>0$ in this situation,
  14141. we will print `\.{\#\#\# -2x=-y+a}'.
  14142. There's a slight complication, however: An independent variable $x$
  14143. can occur both in dependency lists and in proto-dependency lists.
  14144. This makes it necessary to be careful when deciding which coefficient
  14145. is maximal.
  14146. Furthermore, this complication is not so slight when
  14147. a proto-dependent variable is chosen to become independent. For example,
  14148. suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent;
  14149. then we must change $z=.5y-50a+b$ to a proto-dependency, because of the
  14150. large coefficient `50'.
  14151. In order to deal with these complications without wasting too much time,
  14152. we shall link together the occurrences of~$x$ among all the linear
  14153. dependencies, maintaining separate lists for the dependent and
  14154. proto-dependent cases.
  14155. @<Recycle an independent variable@>=
  14156. begin max_c[dependent]:=0; max_c[proto_dependent]:=0;@/
  14157. max_link[dependent]:=null; max_link[proto_dependent]:=null;@/
  14158. q:=link(dep_head);
  14159. while q<>dep_head do
  14160.   begin s:=value_loc(q); {now |link(s)=dep_list(q)|}
  14161.   loop@+  begin r:=link(s);
  14162.     if info(r)=null then goto done;
  14163.     if info(r)<>p then s:=r
  14164.     else  begin t:=type(q); link(s):=link(r); info(r):=q;
  14165.       if abs(value(r))>max_c[t] then
  14166.         @<Record a new maximum coefficient of type |t|@>
  14167.       else  begin link(r):=max_link[t]; max_link[t]:=r;
  14168.         end;
  14169.       end;
  14170.     end;
  14171. done:  q:=link(r);
  14172.   end;
  14173. if (max_c[dependent]>0)or(max_c[proto_dependent]>0) then
  14174.   @<Choose a dependent variable to take the place of the disappearing
  14175.     independent variable, and change all remaining dependencies
  14176.     accordingly@>;
  14177. @ The code for independency removal makes use of three two-word arrays.
  14178. @<Glob...@>=
  14179. @!max_c:array[dependent..proto_dependent] of integer;
  14180.   {max coefficient magnitude}
  14181. @!max_ptr:array[dependent..proto_dependent] of pointer;
  14182.   {where |p| occurs with |max_c|}
  14183. @!max_link:array[dependent..proto_dependent] of pointer;
  14184.   {other occurrences of |p|}
  14185. @ @<Record a new maximum coefficient...@>=
  14186. begin if max_c[t]>0 then
  14187.   begin link(max_ptr[t]):=max_link[t]; max_link[t]:=max_ptr[t];
  14188.   end;
  14189. max_c[t]:=abs(value(r)); max_ptr[t]:=r;
  14190. @ @<Choose a dependent...@>=
  14191. begin if (max_c[dependent]>=fraction_one)or@|
  14192.  (max_c[dependent] div @'10000 >= max_c[proto_dependent]) then
  14193.   t:=dependent
  14194. else t:=proto_dependent;
  14195. @<Determine the dependency list |s| to substitute for the independent
  14196.   variable~|p|@>;
  14197. t:=dependent+proto_dependent-t; {complement |t|}
  14198. if max_c[t]>0 then {we need to pick up an unchosen dependency}
  14199.   begin link(max_ptr[t]):=max_link[t]; max_link[t]:=max_ptr[t];
  14200.   end;
  14201. if t<>dependent then @<Substitute new dependencies in place of |p|@>
  14202. else @<Substitute new proto-dependencies in place of |p|@>;
  14203. flush_node_list(s);
  14204. if fix_needed then fix_dependencies;
  14205. check_arith;
  14206. @ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$,
  14207. and |info(s)| points to the dependent variable~|pp| of type~|t| from
  14208. whose dependency list we have removed node~|s|. We must reinsert
  14209. node~|s| into the dependency list, with coefficient $-1.0$, and with
  14210. |pp| as the new independent variable. Since |pp| will have a larger serial
  14211. number than any other variable, we can put node |s| at the head of the
  14212. list.
  14213. @<Determine the dep...@>=
  14214. s:=max_ptr[t]; pp:=info(s); v:=value(s);
  14215. if t=dependent then value(s):=-fraction_one@+else value(s):=-unity;
  14216. r:=dep_list(pp); link(s):=r;
  14217. while info(r)<>null do r:=link(r);
  14218. q:=link(r); link(r):=null;
  14219. prev_dep(q):=prev_dep(pp); link(prev_dep(pp)):=q;
  14220. new_indep(pp);
  14221. if cur_exp=pp then if cur_type=t then cur_type:=independent;
  14222. if internal[tracing_equations]>0 then @<Show the transformed dependency@>
  14223. @ Now $(-v)$ times the formerly independent variable~|p| is being replaced
  14224. by the dependency list~|s|.
  14225. @<Show the transformed...@>=
  14226. if interesting(p) then
  14227.   begin begin_diagnostic; print_nl("### ");
  14228. @:]]]\#\#\#_}{\.{\#\#\#}@>
  14229.   if v>0 then print_char("-");
  14230.   if t=dependent then vv:=round_fraction(max_c[dependent])
  14231.   else vv:=max_c[proto_dependent];
  14232.   if vv<>unity then print_scaled(vv);
  14233.   print_variable_name(p);
  14234.   while value(p) mod s_scale>0 do
  14235.     begin print("*4"); value(p):=value(p)-2;
  14236.     end;
  14237.   if t=dependent then print_char("=")@+else print(" = ");
  14238.   print_dependency(s,t);
  14239.   end_diagnostic(false);
  14240.   end
  14241. @ Finally, there are dependent and proto-dependent variables whose
  14242. dependency lists must be brought up to date.
  14243. @<Substitute new dependencies...@>=
  14244. for t:=dependent to proto_dependent do
  14245.   begin r:=max_link[t];
  14246.   while r<>null do
  14247.     begin q:=info(r);
  14248.     dep_list(q):=p_plus_fq(dep_list(q),@|
  14249.      make_fraction(value(r),-v),s,t,dependent);
  14250.     if dep_list(q)=dep_final then make_known(q,dep_final);
  14251.     q:=r; r:=link(r); free_node(q,dep_node_size);
  14252.     end;
  14253.   end
  14254. @ @<Substitute new proto...@>=
  14255. for t:=dependent to proto_dependent do
  14256.   begin r:=max_link[t];
  14257.   while r<>null do
  14258.     begin q:=info(r);
  14259.     if t=dependent then {for safety's sake, we change |q| to |proto_dependent|}
  14260.       begin if cur_exp=q then if cur_type=dependent then
  14261.         cur_type:=proto_dependent;
  14262.       dep_list(q):=p_over_v(dep_list(q),unity,dependent,proto_dependent);
  14263.       type(q):=proto_dependent; value(r):=round_fraction(value(r));
  14264.       end;
  14265.     dep_list(q):=p_plus_fq(dep_list(q),@|
  14266.      make_scaled(value(r),-v),s,proto_dependent,proto_dependent);
  14267.     if dep_list(q)=dep_final then make_known(q,dep_final);
  14268.     q:=r; r:=link(r); free_node(q,dep_node_size);
  14269.     end;
  14270.   end
  14271. @ Here are some routines that provide handy combinations of actions
  14272. that are often needed during error recovery. For example,
  14273. `|flush_error|' flushes the current expression, replaces it by
  14274. a given value, and calls |error|.
  14275. Errors often are detected after an extra token has already been scanned.
  14276. The `\\{put\_get}' routines put that token back before calling |error|;
  14277. then they get it back again. (Or perhaps they get another token, if
  14278. the user has changed things.)
  14279. @<Declare the procedure called |flush_cur_exp|@>=
  14280. procedure flush_error(@!v:scaled);@+begin error; flush_cur_exp(v);@+end;
  14281. procedure@?back_error; forward;@t\2@>@/
  14282. procedure@?get_x_next; forward;@t\2@>@/
  14283. procedure put_get_error;@+begin back_error; get_x_next;@+end;
  14284. procedure put_get_flush_error(@!v:scaled);@+begin put_get_error;
  14285.  flush_cur_exp(v);@+end;
  14286. @ A global variable called |var_flag| is set to a special command code
  14287. just before \MF\ calls |scan_expression|, if the expression should be
  14288. treated as a variable when this command code immediately follows. For
  14289. example, |var_flag| is set to |assignment| at the beginning of a
  14290. statement, because we want to know the {\sl location\/} of a variable at
  14291. the left of `\.{:=}', not the {\sl value\/} of that variable.
  14292. The |scan_expression| subroutine calls |scan_tertiary|,
  14293. which calls |scan_secondary|, which calls |scan_primary|, which sets
  14294. |var_flag:=0|. In this way each of the scanning routines ``knows''
  14295. when it has been called with a special |var_flag|, but |var_flag| is
  14296. usually zero.
  14297. A variable preceding a command that equals |var_flag| is converted to a
  14298. token list rather than a value. Furthermore, an `\.{=}' sign following an
  14299. expression with |var_flag=assignment| is not considered to be a relation
  14300. that produces boolean expressions.
  14301. @<Glob...@>=
  14302. @!var_flag:0..max_command_code; {command that wants a variable}
  14303. @ @<Set init...@>=
  14304. var_flag:=0;
  14305. @* \[40] Parsing primary expressions.
  14306. The first parsing routine, |scan_primary|, is also the most complicated one,
  14307. since it involves so many different cases. But each case---with one
  14308. exception---is fairly simple by itself.
  14309. When |scan_primary| begins, the first token of the primary to be scanned
  14310. should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values
  14311. of |cur_type| and |cur_exp| should be either dead or dormant, as explained
  14312. earlier. If |cur_cmd| is not between |min_primary_command| and
  14313. |max_primary_command|, inclusive, a syntax error will be signalled.
  14314. @<Declare the basic parsing subroutines@>=
  14315. procedure scan_primary;
  14316. label restart, done, done1, done2;
  14317. var @!p,@!q,@!r:pointer; {for list manipulation}
  14318. @!c:quarterword; {a primitive operation code}
  14319. @!my_var_flag:0..max_command_code; {initial value of |my_var_flag|}
  14320. @!l_delim,@!r_delim:pointer; {hash addresses of a delimiter pair}
  14321. @<Other local variables for |scan_primary|@>@;
  14322. begin my_var_flag:=var_flag; var_flag:=0;
  14323. restart:check_arith;
  14324. @<Supply diagnostic information, if requested@>;
  14325. case cur_cmd of
  14326. left_delimiter:@<Scan a delimited primary@>;
  14327. begin_group:@<Scan a grouped primary@>;
  14328. string_token:@<Scan a string constant@>;
  14329. numeric_token:@<Scan a primary that starts with a numeric token@>;
  14330. nullary:@<Scan a nullary operation@>;
  14331. unary,type_name,cycle,plus_or_minus:@<Scan a unary operation@>;
  14332. primary_binary:@<Scan a binary operation with `\&{of}' between its operands@>;
  14333. str_op:@<Convert a suffix to a string@>;
  14334. internal_quantity:@<Scan an internal numeric quantity@>;
  14335. capsule_token:make_exp_copy(cur_mod);
  14336. tag_token:@<Scan a variable primary;
  14337.   |goto restart| if it turns out to be a macro@>;
  14338. othercases begin bad_exp("A primary"); goto restart;
  14339. @.A primary expression...@>
  14340.   end
  14341. endcases;@/
  14342. get_x_next; {the routines |goto done| if they don't want this}
  14343. done: if cur_cmd=left_bracket then
  14344.   if cur_type>=known then @<Scan a mediation construction@>;
  14345. @ Errors at the beginning of expressions are flagged by |bad_exp|.
  14346. @p procedure bad_exp(@!s:str_number);
  14347. var save_flag:0..max_command_code;
  14348. begin print_err(s); print(" expression can't begin with `");
  14349. print_cmd_mod(cur_cmd,cur_mod); print_char("'");
  14350. help4("I'm afraid I need some sort of value in order to continue,")@/
  14351.   ("so I've tentatively inserted `0'. You may want to")@/
  14352.   ("delete this zero and insert something else;")@/
  14353.   ("see Chapter 27 of The METAFONTbook for an example.");
  14354. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  14355. back_input; cur_sym:=0; cur_cmd:=numeric_token; cur_mod:=0; ins_error;@/
  14356. save_flag:=var_flag; var_flag:=0; get_x_next;
  14357. var_flag:=save_flag;
  14358. @ @<Supply diagnostic information, if requested@>=
  14359. debug if panicking then check_mem(false);@+gubed@;@/
  14360. if interrupt<>0 then if OK_to_interrupt then
  14361.   begin back_input; check_interrupt; get_x_next;
  14362.   end
  14363. @ @<Scan a delimited primary@>=
  14364. begin l_delim:=cur_sym; r_delim:=cur_mod; get_x_next; scan_expression;
  14365. if (cur_cmd=comma) and (cur_type>=known) then
  14366.   @<Scan the second of a pair of numerics@>
  14367. else check_delimiter(l_delim,r_delim);
  14368. @ The |stash_in| subroutine puts the current (numeric) expression into a field
  14369. within a ``big node.''
  14370. @p procedure stash_in(@!p:pointer);
  14371. var @!q:pointer; {temporary register}
  14372. begin type(p):=cur_type;
  14373. if cur_type=known then value(p):=cur_exp
  14374. else  begin if cur_type=independent then
  14375.     @<Stash an independent |cur_exp| into a big node@>
  14376.   else  begin mem[value_loc(p)]:=mem[value_loc(cur_exp)];
  14377.      {|dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)|}
  14378.     link(prev_dep(p)):=p;
  14379.     end;
  14380.   free_node(cur_exp,value_node_size);
  14381.   end;
  14382. cur_type:=vacuous;
  14383. @ In rare cases the current expression can become |independent|. There
  14384. may be many dependency lists pointing to such an independent capsule,
  14385. so we can't simply move it into place within a big node. Instead,
  14386. we copy it, then recycle it.
  14387. @ @<Stash an independent |cur_exp|...@>=
  14388. begin q:=single_dependency(cur_exp);
  14389. if q=dep_final then
  14390.   begin type(p):=known; value(p):=0; free_node(q,dep_node_size);
  14391.   end
  14392. else  begin type(p):=dependent; new_dep(p,q);
  14393.   end;
  14394. recycle_value(cur_exp);
  14395. @ @<Scan the second of a pair of numerics@>=
  14396. begin p:=get_node(value_node_size); type(p):=pair_type; name_type(p):=capsule;
  14397. init_big_node(p); q:=value(p); stash_in(x_part_loc(q));@/
  14398. get_x_next; scan_expression;
  14399. if cur_type<known then
  14400.   begin exp_err("Nonnumeric ypart has been replaced by 0");
  14401. @.Nonnumeric...replaced by 0@>
  14402.   help4("I thought you were giving me a pair `(x,y)'; but")@/
  14403.     ("after finding a nice xpart `x' I found a ypart `y'")@/
  14404.     ("that isn't of numeric type. So I've changed y to zero.")@/
  14405.     ("(The y that I didn't like appears above the error message.)");
  14406.   put_get_flush_error(0);
  14407.   end;
  14408. stash_in(y_part_loc(q));
  14409. check_delimiter(l_delim,r_delim);
  14410. cur_type:=pair_type; cur_exp:=p;
  14411. @ The local variable |group_line| keeps track of the line
  14412. where a \&{begingroup} command occurred; this will be useful
  14413. in an error message if the group doesn't actually end.
  14414. @<Other local variables for |scan_primary|@>=
  14415. @!group_line:integer; {where a group began}
  14416. @ @<Scan a grouped primary@>=
  14417. begin group_line:=line;
  14418. if internal[tracing_commands]>0 then show_cur_cmd_mod;
  14419. save_boundary_item(p);
  14420. repeat do_statement; {ends with |cur_cmd>=semicolon|}
  14421. until cur_cmd<>semicolon;
  14422. if cur_cmd<>end_group then
  14423.   begin print_err("A group begun on line ");
  14424. @.A group...never ended@>
  14425.   print_int(group_line);
  14426.   print(" never ended");
  14427.   help2("I saw a `begingroup' back there that hasn't been matched")@/
  14428.     ("by `endgroup'. So I've inserted `endgroup' now.");
  14429.   back_error; cur_cmd:=end_group;
  14430.   end;
  14431. unsave; {this might change |cur_type|, if independent variables are recycled}
  14432. if internal[tracing_commands]>0 then show_cur_cmd_mod;
  14433. @ @<Scan a string constant@>=
  14434. begin cur_type:=string_type; cur_exp:=cur_mod;
  14435. @ Later we'll come to procedures that perform actual operations like
  14436. addition, square root, and so on; our purpose now is to do the parsing.
  14437. But we might as well mention those future procedures now, so that the
  14438. suspense won't be too bad:
  14439. \smallskip
  14440. |do_nullary(c)| does primitive operations that have no operands (e.g.,
  14441. `\&{true}' or `\&{pencircle}');
  14442. \smallskip
  14443. |do_unary(c)| applies a primitive operation to the current expression;
  14444. \smallskip
  14445. |do_binary(p,c)| applies a primitive operation to the capsule~|p|
  14446. and the current expression.
  14447. @<Scan a nullary operation@>=do_nullary(cur_mod)
  14448. @ @<Scan a unary operation@>=
  14449. begin c:=cur_mod; get_x_next; scan_primary; do_unary(c); goto done;
  14450. @ A numeric token might be a primary by itself, or it might be the
  14451. numerator of a fraction composed solely of numeric tokens, or it might
  14452. multiply the primary that follows (provided that the primary doesn't begin
  14453. with a plus sign or a minus sign). The code here uses the facts that
  14454. |max_primary_command=plus_or_minus| and
  14455. |max_primary_command-1=numeric_token|. If a fraction is found that is less
  14456. than unity, we try to retain higher precision when we use it in scalar
  14457. multiplication.
  14458. @<Other local variables for |scan_primary|@>=
  14459. @!num,@!denom:scaled; {for primaries that are fractions, like `1/2'}
  14460. @ @<Scan a primary that starts with a numeric token@>=
  14461. begin cur_exp:=cur_mod; cur_type:=known; get_x_next;
  14462. if cur_cmd<>slash then
  14463.   begin num:=0; denom:=0;
  14464.   end
  14465. else  begin get_x_next;
  14466.   if cur_cmd<>numeric_token then
  14467.     begin back_input;
  14468.     cur_cmd:=slash; cur_mod:=over; cur_sym:=frozen_slash;
  14469.     goto done;
  14470.     end;
  14471.   num:=cur_exp; denom:=cur_mod;
  14472.   if denom=0 then @<Protest division by zero@>
  14473.   else cur_exp:=make_scaled(num,denom);
  14474.   check_arith; get_x_next;
  14475.   end;
  14476. if cur_cmd>=min_primary_command then
  14477.  if cur_cmd<numeric_token then {in particular, |cur_cmd<>plus_or_minus|}
  14478.   begin p:=stash_cur_exp; scan_primary;
  14479.   if (abs(num)>=abs(denom))or(cur_type<pair_type) then do_binary(p,times)
  14480.   else  begin frac_mult(num,denom);
  14481.     free_node(p,value_node_size);
  14482.     end;
  14483.   end;
  14484. goto done;
  14485. @ @<Protest division...@>=
  14486. begin print_err("Division by zero");
  14487. @.Division by zero@>
  14488. help1("I'll pretend that you meant to divide by 1."); error;
  14489. @ @<Scan a binary operation with `\&{of}' between its operands@>=
  14490. begin c:=cur_mod; get_x_next; scan_expression;
  14491. if cur_cmd<>of_token then
  14492.   begin missing_err("of"); print(" for "); print_cmd_mod(primary_binary,c);
  14493. @.Missing `of'@>
  14494.   help1("I've got the first argument; will look now for the other.");
  14495.   back_error;
  14496.   end;
  14497. p:=stash_cur_exp; get_x_next; scan_primary; do_binary(p,c); goto done;
  14498. @ @<Convert a suffix to a string@>=
  14499. begin get_x_next; scan_suffix; old_setting:=selector; selector:=new_string;
  14500. show_token_list(cur_exp,null,100000,0); flush_token_list(cur_exp);
  14501. cur_exp:=make_string; selector:=old_setting; cur_type:=string_type;
  14502. goto done;
  14503. @ If an internal quantity appears all by itself on the left of an
  14504. assignment, we return a token list of length one, containing the address
  14505. of the internal quantity plus |hash_end|. (This accords with the conventions
  14506. of the save stack, as described earlier.)
  14507. @<Scan an internal...@>=
  14508. begin q:=cur_mod;
  14509. if my_var_flag=assignment then
  14510.   begin get_x_next;
  14511.   if cur_cmd=assignment then
  14512.     begin cur_exp:=get_avail;
  14513.     info(cur_exp):=q+hash_end; cur_type:=token_list; goto done;
  14514.     end;
  14515.   back_input;
  14516.   end;
  14517. cur_type:=known; cur_exp:=internal[q];
  14518. @ The most difficult part of |scan_primary| has been saved for last, since
  14519. it was necessary to build up some confidence first. We can now face the task
  14520. of scanning a variable.
  14521. As we scan a variable, we build a token list containing the relevant
  14522. names and subscript values, simultaneously following along in the
  14523. ``collective'' structure to see if we are actually dealing with a macro
  14524. instead of a value.
  14525. The local variables |pre_head| and |post_head| will point to the beginning
  14526. of the prefix and suffix lists; |tail| will point to the end of the list
  14527. that is currently growing.
  14528. Another local variable, |tt|, contains partial information about the
  14529. declared type of the variable-so-far. If |tt>=unsuffixed_macro|, the
  14530. relation |tt=type(q)| will always hold. If |tt=undefined|, the routine
  14531. doesn't bother to update its information about type. And if
  14532. |undefined<tt<unsuffixed_macro|, the precise value of |tt| isn't critical.
  14533. @ @<Other local variables for |scan_primary|@>=
  14534. @!pre_head,@!post_head,@!tail:pointer;
  14535.   {prefix and suffix list variables}
  14536. @!tt:small_number; {approximation to the type of the variable-so-far}
  14537. @!t:pointer; {a token}
  14538. @!macro_ref:pointer; {reference count for a suffixed macro}
  14539. @ @<Scan a variable primary...@>=
  14540. begin fast_get_avail(pre_head); tail:=pre_head; post_head:=null; tt:=vacuous;
  14541. loop@+  begin t:=cur_tok; link(tail):=t;
  14542.   if tt<>undefined then
  14543.     begin @<Find the approximate type |tt| and corresponding~|q|@>;
  14544.     if tt>=unsuffixed_macro then
  14545.       @<Either begin an unsuffixed macro call or
  14546.         prepare for a suffixed one@>;
  14547.     end;
  14548.   get_x_next; tail:=t;
  14549.   if cur_cmd=left_bracket then
  14550.     @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>;
  14551.   if cur_cmd>max_suffix_token then goto done1;
  14552.   if cur_cmd<min_suffix_token then goto done1;
  14553.   end; {now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token|}
  14554. done1:@<Handle unusual cases that masquerade as variables, and |goto restart|
  14555.   or |goto done| if appropriate;
  14556.   otherwise make a copy of the variable and |goto done|@>;
  14557. @ @<Either begin an unsuffixed macro call or...@>=
  14558. begin link(tail):=null;
  14559. if tt>unsuffixed_macro then {|tt=suffixed_macro|}
  14560.   begin post_head:=get_avail; tail:=post_head; link(tail):=t;@/
  14561.   tt:=undefined; macro_ref:=value(q); add_mac_ref(macro_ref);
  14562.   end
  14563. else @<Set up unsuffixed macro call and |goto restart|@>;
  14564. @ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>=
  14565. begin get_x_next; scan_expression;
  14566. if cur_cmd<>right_bracket then
  14567.   @<Put the left bracket and the expression back to be rescanned@>
  14568. else  begin if cur_type<>known then bad_subscript;
  14569.   cur_cmd:=numeric_token; cur_mod:=cur_exp; cur_sym:=0;
  14570.   end;
  14571. @ The left bracket that we thought was introducing a subscript might have
  14572. actually been the left bracket in a mediation construction like `\.{x[a,b]}'.
  14573. So we don't issue an error message at this point; but we do want to back up
  14574. so as to avoid any embarrassment about our incorrect assumption.
  14575. @<Put the left bracket and the expression back to be rescanned@>=
  14576. begin back_input; {that was the token following the current expression}
  14577. back_expr; cur_cmd:=left_bracket; cur_mod:=0; cur_sym:=frozen_left_bracket;
  14578. @ Here's a routine that puts the current expression back to be read again.
  14579. @p procedure back_expr;
  14580. var @!p:pointer; {capsule token}
  14581. begin p:=stash_cur_exp; link(p):=null; back_list(p);
  14582. @ Unknown subscripts lead to the following error message.
  14583. @p procedure bad_subscript;
  14584. begin exp_err("Improper subscript has been replaced by zero");
  14585. @.Improper subscript...@>
  14586. help3("A bracketed subscript must have a known numeric value;")@/
  14587.   ("unfortunately, what I found was the value that appears just")@/
  14588.   ("above this error message. So I'll try a zero subscript.");
  14589. flush_error(0);
  14590. @ Every time we call |get_x_next|, there's a chance that the variable we've
  14591. been looking at will disappear. Thus, we cannot safely keep |q| pointing
  14592. into the variable structure; we need to start searching from the root each time.
  14593. @<Find the approximate type |tt| and corresponding~|q|@>=
  14594. @^inner loop@>
  14595. begin p:=link(pre_head); q:=info(p); tt:=undefined;
  14596. if eq_type(q) mod outer_tag=tag_token then
  14597.   begin q:=equiv(q);
  14598.   if q=null then goto done2;
  14599.   loop@+  begin p:=link(p);
  14600.     if p=null then
  14601.       begin tt:=type(q); goto done2;
  14602.       end;
  14603.     if type(q)<>structured then goto done2;
  14604.     q:=link(attr_head(q)); {the |collective_subscript| attribute}
  14605.     if p>=hi_mem_min then {it's not a subscript}
  14606.       begin repeat q:=link(q);
  14607.       until attr_loc(q)>=info(p);
  14608.       if attr_loc(q)>info(p) then goto done2;
  14609.       end;
  14610.     end;
  14611.   end;
  14612. done2:end
  14613. @ How do things stand now? Well, we have scanned an entire variable name,
  14614. including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and
  14615. |cur_sym| represent the token that follows. If |post_head=null|, a
  14616. token list for this variable name starts at |link(pre_head)|, with all
  14617. subscripts evaluated. But if |post_head<>null|, the variable turned out
  14618. to be a suffixed macro; |pre_head| is the head of the prefix list, while
  14619. |post_head| is the head of a token list containing both `\.{\AT!}' and
  14620. the suffix.
  14621. Our immediate problem is to see if this variable still exists. (Variable
  14622. structures can change drastically whenever we call |get_x_next|; users
  14623. aren't supposed to do this, but the fact that it is possible means that
  14624. we must be cautious.)
  14625. The following procedure prints an error message when a variable
  14626. unexpectedly disappears. Its help message isn't quite right for
  14627. our present purposes, but we'll be able to fix that up.
  14628. @p procedure obliterated(@!q:pointer);
  14629. begin print_err("Variable "); show_token_list(q,null,1000,0);
  14630. print(" has been obliterated");
  14631. @.Variable...obliterated@>
  14632. help5("It seems you did a nasty thing---probably by accident,")@/
  14633.   ("but nevertheless you nearly hornswoggled me...")@/
  14634.   ("While I was evaluating the right-hand side of this")@/
  14635.   ("command, something happened, and the left-hand side")@/
  14636.   ("is no longer a variable! So I won't change anything.");
  14637. @ If the variable does exist, we also need to check
  14638. for a few other special cases before deciding that a plain old ordinary
  14639. variable has, indeed, been scanned.
  14640. @<Handle unusual cases that masquerade as variables...@>=
  14641. if post_head<>null then @<Set up suffixed macro call and |goto restart|@>;
  14642. q:=link(pre_head); free_avail(pre_head);
  14643. if cur_cmd=my_var_flag then
  14644.   begin cur_type:=token_list; cur_exp:=q; goto done;
  14645.   end;
  14646. p:=find_variable(q);
  14647. if p<>null then make_exp_copy(p)
  14648. else  begin obliterated(q);@/
  14649.   help_line[2]:="While I was evaluating the suffix of this variable,";
  14650.   help_line[1]:="something was redefined, and it's no longer a variable!";
  14651.   help_line[0]:="In order to get back on my feet, I've inserted `0' instead.";
  14652.   put_get_flush_error(0);
  14653.   end;
  14654. flush_node_list(q); goto done
  14655. @ The only complication associated with macro calling is that the prefix
  14656. and ``at'' parameters must be packaged in an appropriate list of lists.
  14657. @<Set up unsuffixed macro call and |goto restart|@>=
  14658. begin p:=get_avail; info(pre_head):=link(pre_head); link(pre_head):=p;
  14659. info(p):=t; macro_call(value(q),pre_head,null); get_x_next; goto restart;
  14660. @ If the ``variable'' that turned out to be a suffixed macro no longer exists,
  14661. we don't care, because we have reserved a pointer (|macro_ref|) to its
  14662. token list.
  14663. @<Set up suffixed macro call and |goto restart|@>=
  14664. begin back_input; p:=get_avail; q:=link(post_head);
  14665. info(pre_head):=link(pre_head); link(pre_head):=post_head;
  14666. info(post_head):=q; link(post_head):=p; info(p):=link(q); link(q):=null;
  14667. macro_call(macro_ref,pre_head,null); decr(ref_count(macro_ref));
  14668. get_x_next; goto restart;
  14669. @ Our remaining job is simply to make a copy of the value that has been
  14670. found. Some cases are harder than others, but complexity arises solely
  14671. because of the multiplicity of possible cases.
  14672. @<Declare the procedure called |make_exp_copy|@>=
  14673. @t\4@>@<Declare subroutines needed by |make_exp_copy|@>@;
  14674. procedure make_exp_copy(@!p:pointer);
  14675. label restart;
  14676. var @!q,@!r,@!t:pointer; {registers for list manipulation}
  14677. begin restart: cur_type:=type(p);
  14678. case cur_type of
  14679. vacuous,boolean_type,known:cur_exp:=value(p);
  14680. unknown_types:cur_exp:=new_ring_entry(p);
  14681. string_type:begin cur_exp:=value(p); add_str_ref(cur_exp);
  14682.   end;
  14683. pen_type:begin cur_exp:=value(p); add_pen_ref(cur_exp);
  14684.   end;
  14685. picture_type:cur_exp:=copy_edges(value(p));
  14686. path_type,future_pen:cur_exp:=copy_path(value(p));
  14687. transform_type,pair_type:@<Copy the big node |p|@>;
  14688. dependent,proto_dependent:encapsulate(copy_dep_list(dep_list(p)));
  14689. numeric_type:begin new_indep(p); goto restart;
  14690.   end;
  14691. independent: begin q:=single_dependency(p);
  14692.   if q=dep_final then
  14693.     begin cur_type:=known; cur_exp:=0; free_node(q,value_node_size);
  14694.     end
  14695.   else  begin cur_type:=dependent; encapsulate(q);
  14696.     end;
  14697.   end;
  14698. othercases confusion("copy")
  14699. @:this can't happen copy}{\quad copy@>
  14700. endcases;
  14701. @ The |encapsulate| subroutine assumes that |dep_final| is the
  14702. tail of dependency list~|p|.
  14703. @<Declare subroutines needed by |make_exp_copy|@>=
  14704. procedure encapsulate(@!p:pointer);
  14705. begin cur_exp:=get_node(value_node_size); type(cur_exp):=cur_type;
  14706. name_type(cur_exp):=capsule; new_dep(cur_exp,p);
  14707. @ The most tedious case arises when the user refers to a
  14708. \&{pair} or \&{transform} variable; we must copy several fields,
  14709. each of which can be |independent|, |dependent|, |proto_dependent|,
  14710. or |known|.
  14711. @<Copy the big node |p|@>=
  14712. begin if value(p)=null then init_big_node(p);
  14713. t:=get_node(value_node_size); name_type(t):=capsule; type(t):=cur_type;
  14714. init_big_node(t);@/
  14715. q:=value(p)+big_node_size[cur_type]; r:=value(t)+big_node_size[cur_type];
  14716. repeat q:=q-2; r:=r-2; install(r,q);
  14717. until q=value(p);
  14718. cur_exp:=t;
  14719. @ The |install| procedure copies a numeric field~|q| into field~|r| of
  14720. a big node that will be part of a capsule.
  14721. @<Declare subroutines needed by |make_exp_copy|@>=
  14722. procedure install(@!r,@!q:pointer);
  14723. var p:pointer; {temporary register}
  14724. begin if type(q)=known then
  14725.   begin value(r):=value(q); type(r):=known;
  14726.   end
  14727. else  if type(q)=independent then
  14728.     begin p:=single_dependency(q);
  14729.     if p=dep_final then
  14730.       begin type(r):=known; value(r):=0; free_node(p,value_node_size);
  14731.       end
  14732.     else  begin type(r):=dependent; new_dep(r,p);
  14733.       end;
  14734.     end
  14735.   else  begin type(r):=type(q); new_dep(r,copy_dep_list(dep_list(q)));
  14736.     end;
  14737. @ Expressions of the form `\.{a[b,c]}' are converted into
  14738. `\.{b+a*(c-b)}', without checking the types of \.b~or~\.c,
  14739. provided that \.a is numeric.
  14740. @<Scan a mediation...@>=
  14741. begin p:=stash_cur_exp; get_x_next; scan_expression;
  14742. if cur_cmd<>comma then
  14743.   begin @<Put the left bracket and the expression back...@>;
  14744.   unstash_cur_exp(p);
  14745.   end
  14746. else  begin q:=stash_cur_exp; get_x_next; scan_expression;
  14747.   if cur_cmd<>right_bracket then
  14748.     begin missing_err("]");@/
  14749. @.Missing `]'@>
  14750.     help3("I've scanned an expression of the form `a[b,c',")@/
  14751.       ("so a right bracket should have come next.")@/
  14752.       ("I shall pretend that one was there.");@/
  14753.     back_error;
  14754.     end;
  14755.   r:=stash_cur_exp; make_exp_copy(q);@/
  14756.   do_binary(r,minus); do_binary(p,times); do_binary(q,plus); get_x_next;
  14757.   end;
  14758. @ Here is a comparatively simple routine that is used to scan the
  14759. \&{suffix} parameters of a macro.
  14760. @<Declare the basic parsing subroutines@>=
  14761. procedure scan_suffix;
  14762. label done;
  14763. var @!h,@!t:pointer; {head and tail of the list being built}
  14764. @!p:pointer; {temporary register}
  14765. begin h:=get_avail; t:=h;
  14766. loop@+  begin if cur_cmd=left_bracket then
  14767.     @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>;
  14768.   if cur_cmd=numeric_token then p:=new_num_tok(cur_mod)
  14769.   else if (cur_cmd=tag_token)or(cur_cmd=internal_quantity) then
  14770.     begin p:=get_avail; info(p):=cur_sym;
  14771.     end
  14772.   else goto done;
  14773.   link(t):=p; t:=p; get_x_next;
  14774.   end;
  14775. done: cur_exp:=link(h); free_avail(h); cur_type:=token_list;
  14776. @ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>=
  14777. begin get_x_next; scan_expression;
  14778. if cur_type<>known then bad_subscript;
  14779. if cur_cmd<>right_bracket then
  14780.   begin missing_err("]");@/
  14781. @.Missing `]'@>
  14782.   help3("I've seen a `[' and a subscript value, in a suffix,")@/
  14783.     ("so a right bracket should have come next.")@/
  14784.     ("I shall pretend that one was there.");@/
  14785.   back_error;
  14786.   end;
  14787. cur_cmd:=numeric_token; cur_mod:=cur_exp;
  14788. @* \[41] Parsing secondary and higher expressions.
  14789. After the intricacies of |scan_primary|\kern-1pt,
  14790. the |scan_secondary| routine is
  14791. refreshingly simple. It's not trivial, but the operations are relatively
  14792. straightforward; the main difficulty is, again, that expressions and data
  14793. structures might change drastically every time we call |get_x_next|, so a
  14794. cautious approach is mandatory. For example, a macro defined by
  14795. \&{primarydef} might have disappeared by the time its second argument has
  14796. been scanned; we solve this by increasing the reference count of its token
  14797. list, so that the macro can be called even after it has been clobbered.
  14798. @<Declare the basic parsing subroutines@>=
  14799. procedure scan_secondary;
  14800. label restart,continue;
  14801. var @!p:pointer; {for list manipulation}
  14802. @!c,@!d:halfword; {operation codes or modifiers}
  14803. @!mac_name:pointer; {token defined with \&{primarydef}}
  14804. begin restart:if(cur_cmd<min_primary_command)or@|
  14805.  (cur_cmd>max_primary_command) then
  14806.   bad_exp("A secondary");
  14807. @.A secondary expression...@>
  14808. scan_primary;
  14809. continue: if cur_cmd<=max_secondary_command then
  14810.  if cur_cmd>=min_secondary_command then
  14811.   begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd;
  14812.   if d=secondary_primary_macro then
  14813.     begin mac_name:=cur_sym; add_mac_ref(c);
  14814.     end;
  14815.   get_x_next; scan_primary;
  14816.   if d<>secondary_primary_macro then do_binary(p,c)
  14817.   else  begin back_input; binary_mac(p,c,mac_name);
  14818.     decr(ref_count(c)); get_x_next; goto restart;
  14819.     end;
  14820.   goto continue;
  14821.   end;
  14822. @ The following procedure calls a macro that has two parameters,
  14823. |p| and |cur_exp|.
  14824. @p procedure binary_mac(@!p,@!c,@!n:pointer);
  14825. var @!q,@!r:pointer; {nodes in the parameter list}
  14826. begin q:=get_avail; r:=get_avail; link(q):=r;@/
  14827. info(q):=p; info(r):=stash_cur_exp;@/
  14828. macro_call(c,q,n);
  14829. @ The next procedure, |scan_tertiary|, is pretty much the same deal.
  14830. @<Declare the basic parsing subroutines@>=
  14831. procedure scan_tertiary;
  14832. label restart,continue;
  14833. var @!p:pointer; {for list manipulation}
  14834. @!c,@!d:halfword; {operation codes or modifiers}
  14835. @!mac_name:pointer; {token defined with \&{secondarydef}}
  14836. begin restart:if(cur_cmd<min_primary_command)or@|
  14837.  (cur_cmd>max_primary_command) then
  14838.   bad_exp("A tertiary");
  14839. @.A tertiary expression...@>
  14840. scan_secondary;
  14841. if cur_type=future_pen then materialize_pen;
  14842. continue: if cur_cmd<=max_tertiary_command then
  14843.  if cur_cmd>=min_tertiary_command then
  14844.   begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd;
  14845.   if d=tertiary_secondary_macro then
  14846.     begin mac_name:=cur_sym; add_mac_ref(c);
  14847.     end;
  14848.   get_x_next; scan_secondary;
  14849.   if d<>tertiary_secondary_macro then do_binary(p,c)
  14850.   else  begin back_input; binary_mac(p,c,mac_name);
  14851.     decr(ref_count(c)); get_x_next; goto restart;
  14852.     end;
  14853.   goto continue;
  14854.   end;
  14855. @ A |future_pen| becomes a full-fledged pen here.
  14856. @p procedure materialize_pen;
  14857. label common_ending;
  14858. var @!a_minus_b,@!a_plus_b,@!major_axis,@!minor_axis:scaled; {ellipse variables}
  14859. @!theta:angle; {amount by which the ellipse has been rotated}
  14860. @!p:pointer; {path traverser}
  14861. @!q:pointer; {the knot list to be made into a pen}
  14862. begin q:=cur_exp;
  14863. if left_type(q)=endpoint then
  14864.   begin print_err("Pen path must be a cycle");
  14865. @.Pen path must be a cycle@>
  14866.   help2("I can't make a pen from the given path.")@/
  14867.   ("So I've replaced it by the trivial path `(0,0)..cycle'.");
  14868.   put_get_error; cur_exp:=null_pen; goto common_ending;
  14869.   end
  14870. else if left_type(q)=open then
  14871.   @<Change node |q| to a path for an elliptical pen@>;
  14872. cur_exp:=make_pen(q);
  14873. common_ending: toss_knot_list(q); cur_type:=pen_type;
  14874. @ We placed the three points $(0,0)$, $(1,0)$, $(0,1)$ into a \&{pencircle},
  14875. and they have now been transformed to $(u,v)$, $(A+u,B+v)$, $(C+u,D+v)$;
  14876. this gives us enough information to deduce the transformation
  14877. $(x,y)\mapsto(Ax+Cy+u,Bx+Dy+v)$.
  14878. Given ($A,B,C,D)$ we can always find $(a,b,\theta,\phi)$ such that
  14879. $$\eqalign{A&=a\cos\phi\cos\theta-b\sin\phi\sin\theta;\cr
  14880. B&=a\cos\phi\sin\theta+b\sin\phi\cos\theta;\cr
  14881. C&=-a\sin\phi\cos\theta-b\cos\phi\sin\theta;\cr
  14882. D&=-a\sin\phi\sin\theta+b\cos\phi\cos\theta.\cr}$$
  14883. In this notation, the unit circle $(\cos t,\sin t)$ is transformed into
  14884. $$\bigl(a\cos(\phi+t)\cos\theta-b\sin(\phi+t)\sin\theta,\;
  14885. a\cos(\phi+t)\sin\theta+b\sin(\phi+t)\cos\theta\bigr)\;+\;(u,v),$$
  14886. which is an ellipse with semi-axes~$(a,b)$, rotated by~$\theta$ and
  14887. shifted by~$(u,v)$. To solve the stated equations, we note that it is
  14888. necessary and sufficient to solve
  14889. $$\eqalign{A-D&=(a-b)\cos(\theta-\phi),\cr
  14890. B+C&=(a-b)\sin(\theta-\phi),\cr}
  14891. \qquad
  14892. \eqalign{A+D&=(a+b)\cos(\theta+\phi),\cr
  14893. B-C&=(a+b)\sin(\theta+\phi);\cr}$$
  14894. and it is easy to find $a-b$, $a+b$, $\theta-\phi$, and $\theta+\phi$
  14895. from these formulas.
  14896. The code below uses |(txx,tyx,txy,tyy,tx,ty)| to stand for
  14897. $(A,B,C,D,u,v)$.
  14898. @<Change node |q|...@>=
  14899. begin tx:=x_coord(q); ty:=y_coord(q);
  14900. txx:=left_x(q)-tx; tyx:=left_y(q)-ty;
  14901. txy:=right_x(q)-tx; tyy:=right_y(q)-ty;
  14902. a_minus_b:=pyth_add(txx-tyy,tyx+txy); a_plus_b:=pyth_add(txx+tyy,tyx-txy);
  14903. major_axis:=half(a_minus_b+a_plus_b); minor_axis:=half(abs(a_plus_b-a_minus_b));
  14904. if major_axis=minor_axis then theta:=0 {circle}
  14905. else theta:=half(n_arg(txx-tyy,tyx+txy)+n_arg(txx+tyy,tyx-txy));
  14906. free_node(q,knot_node_size);
  14907. q:=make_ellipse(major_axis,minor_axis,theta);
  14908. if (tx<>0)or(ty<>0) then @<Shift the coordinates of path |q|@>;
  14909. @ @<Shift the coordinates of path |q|@>=
  14910. begin p:=q;
  14911. repeat x_coord(p):=x_coord(p)+tx; y_coord(p):=y_coord(p)+ty; p:=link(p);
  14912. until p=q;
  14913. @ Finally we reach the deepest level in our quartet of parsing routines.
  14914. This one is much like the others; but it has an extra complication from
  14915. paths, which materialize here.
  14916. @d continue_path=25 {a label inside of |scan_expression|}
  14917. @d finish_path=26 {another}
  14918. @<Declare the basic parsing subroutines@>=
  14919. procedure scan_expression;
  14920. label restart,done,continue,continue_path,finish_path,exit;
  14921. var @!p,@!q,@!r,@!pp,@!qq:pointer; {for list manipulation}
  14922. @!c,@!d:halfword; {operation codes or modifiers}
  14923. @!my_var_flag:0..max_command_code; {initial value of |var_flag|}
  14924. @!mac_name:pointer; {token defined with \&{tertiarydef}}
  14925. @!cycle_hit:boolean; {did a path expression just end with `\&{cycle}'?}
  14926. @!x,@!y:scaled; {explicit coordinates or tension at a path join}
  14927. @!t:endpoint..open; {knot type following a path join}
  14928. begin my_var_flag:=var_flag;
  14929. restart:if(cur_cmd<min_primary_command)or@|
  14930.  (cur_cmd>max_primary_command) then
  14931.   bad_exp("An");
  14932. @.An expression...@>
  14933. scan_tertiary;
  14934. continue: if cur_cmd<=max_expression_command then
  14935.  if cur_cmd>=min_expression_command then
  14936.   if (cur_cmd<>equals)or(my_var_flag<>assignment) then
  14937.   begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd;
  14938.   if d=expression_tertiary_macro then
  14939.     begin mac_name:=cur_sym; add_mac_ref(c);
  14940.     end;
  14941.   if (d<ampersand)or((d=ampersand)and@|
  14942.    ((type(p)=pair_type)or(type(p)=path_type))) then
  14943.     @<Scan a path construction operation;
  14944.       but |return| if |p| has the wrong type@>
  14945.   else  begin get_x_next; scan_tertiary;
  14946.     if d<>expression_tertiary_macro then do_binary(p,c)
  14947.     else  begin back_input; binary_mac(p,c,mac_name);
  14948.       decr(ref_count(c)); get_x_next; goto restart;
  14949.       end;
  14950.     end;
  14951.   goto continue;
  14952.   end;
  14953. exit:end;
  14954. @ The reader should review the data structure conventions for paths before
  14955. hoping to understand the next part of this code.
  14956. @<Scan a path construction operation...@>=
  14957. begin cycle_hit:=false;
  14958. @<Convert the left operand, |p|, into a partial path ending at~|q|;
  14959.   but |return| if |p| doesn't have a suitable type@>;
  14960. continue_path: @<Determine the path join parameters;
  14961.   but |goto finish_path| if there's only a direction specifier@>;
  14962. if cur_cmd=cycle then @<Get ready to close a cycle@>
  14963. else  begin scan_tertiary;
  14964.   @<Convert the right operand, |cur_exp|,
  14965.     into a partial path from |pp| to~|qq|@>;
  14966.   end;
  14967. @<Join the partial paths and reset |p| and |q| to the head and tail
  14968.   of the result@>;
  14969. if cur_cmd>=min_expression_command then
  14970.  if cur_cmd<=ampersand then if not cycle_hit then goto continue_path;
  14971. finish_path:
  14972. @<Choose control points for the path and put the result into |cur_exp|@>;
  14973. @ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>=
  14974. begin unstash_cur_exp(p);
  14975. if cur_type=pair_type then p:=new_knot
  14976. else if cur_type=path_type then p:=cur_exp
  14977. else return;
  14978. q:=p;
  14979. while link(q)<>p do q:=link(q);
  14980. if left_type(p)<>endpoint then {open up a cycle}
  14981.   begin r:=copy_knot(p); link(q):=r; q:=r;
  14982.   end;
  14983. left_type(p):=open; right_type(q):=open;
  14984. @ A pair of numeric values is changed into a knot node for a one-point path
  14985. when \MF\ discovers that the pair is part of a path.
  14986. @p@t\4@>@<Declare the procedure called |known_pair|@>@;
  14987. function new_knot:pointer; {convert a pair to a knot with two endpoints}
  14988. var @!q:pointer; {the new node}
  14989. begin q:=get_node(knot_node_size); left_type(q):=endpoint;
  14990. right_type(q):=endpoint; link(q):=q;@/
  14991. known_pair; x_coord(q):=cur_x; y_coord(q):=cur_y;
  14992. new_knot:=q;
  14993. @ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components
  14994. of the current expression, assuming that the current expression is a
  14995. pair of known numerics. Unknown components are zeroed, and the
  14996. current expression is flushed.
  14997. @<Declare the procedure called |known_pair|@>=
  14998. procedure known_pair;
  14999. var @!p:pointer; {the pair node}
  15000. begin if cur_type<>pair_type then
  15001.   begin exp_err("Undefined coordinates have been replaced by (0,0)");
  15002. @.Undefined coordinates...@>
  15003.   help5("I need x and y numbers for this part of the path.")@/
  15004.     ("The value I found (see above) was no good;")@/
  15005.     ("so I'll try to keep going by using zero instead.")@/
  15006.     ("(Chapter 27 of The METAFONTbook explains that")@/
  15007. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  15008.     ("you might want to type `I ???' now.)");
  15009.   put_get_flush_error(0); cur_x:=0; cur_y:=0;
  15010.   end
  15011. else  begin p:=value(cur_exp);
  15012.   @<Make sure that both |x| and |y| parts of |p| are known;
  15013.     copy them into |cur_x| and |cur_y|@>;
  15014.   flush_cur_exp(0);
  15015.   end;
  15016. @ @<Make sure that both |x| and |y| parts of |p| are known...@>=
  15017. if type(x_part_loc(p))=known then cur_x:=value(x_part_loc(p))
  15018. else  begin disp_err(x_part_loc(p),
  15019.     "Undefined x coordinate has been replaced by 0");
  15020. @.Undefined coordinates...@>
  15021.   help5("I need a `known' x value for this part of the path.")@/
  15022.     ("The value I found (see above) was no good;")@/
  15023.     ("so I'll try to keep going by using zero instead.")@/
  15024.     ("(Chapter 27 of The METAFONTbook explains that")@/
  15025. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  15026.     ("you might want to type `I ???' now.)");
  15027.   put_get_error; recycle_value(x_part_loc(p)); cur_x:=0;
  15028.   end;
  15029. if type(y_part_loc(p))=known then cur_y:=value(y_part_loc(p))
  15030. else  begin disp_err(y_part_loc(p),
  15031.     "Undefined y coordinate has been replaced by 0");
  15032.   help5("I need a `known' y value for this part of the path.")@/
  15033.     ("The value I found (see above) was no good;")@/
  15034.     ("so I'll try to keep going by using zero instead.")@/
  15035.     ("(Chapter 27 of The METAFONTbook explains that")@/
  15036.     ("you might want to type `I ???' now.)");
  15037.   put_get_error; recycle_value(y_part_loc(p)); cur_y:=0;
  15038.   end
  15039. @ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|.
  15040. @<Determine the path join parameters...@>=
  15041. if cur_cmd=left_brace then
  15042.   @<Put the pre-join direction information into node |q|@>;
  15043. d:=cur_cmd;
  15044. if d=path_join then @<Determine the tension and/or control points@>
  15045. else if d<>ampersand then goto finish_path;
  15046. get_x_next;
  15047. if cur_cmd=left_brace then
  15048.   @<Put the post-join direction information into |x| and |t|@>
  15049. else if right_type(q)<>explicit then
  15050.   begin t:=open; x:=0;
  15051.   end
  15052. @ The |scan_direction| subroutine looks at the directional information
  15053. that is enclosed in braces, and also scans ahead to the following character.
  15054. A type code is returned, either |open| (if the direction was $(0,0)$),
  15055. or |curl| (if the direction was a curl of known value |cur_exp|), or
  15056. |given| (if the direction is given by the |angle| value that now
  15057. appears in |cur_exp|).
  15058. There's nothing difficult about this subroutine, but the program is rather
  15059. lengthy because a variety of potential errors need to be nipped in the bud.
  15060. @p function scan_direction:small_number;
  15061. var @!t:given..open; {the type of information found}
  15062. @!x:scaled; {an |x| coordinate}
  15063. begin get_x_next;
  15064. if cur_cmd=curl_command then @<Scan a curl specification@>
  15065. else @<Scan a given direction@>;
  15066. if cur_cmd<>right_brace then
  15067.   begin missing_err("}");@/
  15068. @.Missing `\char`\}'@>
  15069.   help3("I've scanned a direction spec for part of a path,")@/
  15070.     ("so a right brace should have come next.")@/
  15071.     ("I shall pretend that one was there.");@/
  15072.   back_error;
  15073.   end;
  15074. get_x_next; scan_direction:=t;
  15075. @ @<Scan a curl specification@>=
  15076. begin get_x_next; scan_expression;
  15077. if (cur_type<>known)or(cur_exp<0) then
  15078.   begin exp_err("Improper curl has been replaced by 1");
  15079. @.Improper curl@>
  15080.   help1("A curl must be a known, nonnegative number.");
  15081.   put_get_flush_error(unity);
  15082.   end;
  15083. t:=curl;
  15084. @ @<Scan a given direction@>=
  15085. begin scan_expression;
  15086. if cur_type>pair_type then @<Get given directions separated by commas@>
  15087. else known_pair;
  15088. if (cur_x=0)and(cur_y=0) then t:=open
  15089. else  begin t:=given; cur_exp:=n_arg(cur_x,cur_y);
  15090.   end;
  15091. @ @<Get given directions separated by commas@>=
  15092. begin if cur_type<>known then
  15093.   begin exp_err("Undefined x coordinate has been replaced by 0");
  15094. @.Undefined coordinates...@>
  15095.   help5("I need a `known' x value for this part of the path.")@/
  15096.     ("The value I found (see above) was no good;")@/
  15097.     ("so I'll try to keep going by using zero instead.")@/
  15098.     ("(Chapter 27 of The METAFONTbook explains that")@/
  15099. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  15100.     ("you might want to type `I ???' now.)");
  15101.   put_get_flush_error(0);
  15102.   end;
  15103. x:=cur_exp;
  15104. if cur_cmd<>comma then
  15105.   begin missing_err(",");@/
  15106. @.Missing `,'@>
  15107.   help2("I've got the x coordinate of a path direction;")@/
  15108.     ("will look for the y coordinate next.");
  15109.   back_error;
  15110.   end;
  15111. get_x_next; scan_expression;
  15112. if cur_type<>known then
  15113.   begin exp_err("Undefined y coordinate has been replaced by 0");
  15114.   help5("I need a `known' y value for this part of the path.")@/
  15115.     ("The value I found (see above) was no good;")@/
  15116.     ("so I'll try to keep going by using zero instead.")@/
  15117.     ("(Chapter 27 of The METAFONTbook explains that")@/
  15118.     ("you might want to type `I ???' now.)");
  15119.   put_get_flush_error(0);
  15120.   end;
  15121. cur_y:=cur_exp; cur_x:=x;
  15122. @ At this point |right_type(q)| is usually |open|, but it may have been
  15123. set to some other value by a previous splicing operation. We must maintain
  15124. the value of |right_type(q)| in unusual cases such as
  15125. `\.{..z1\{z2\}\&\{z3\}z1\{0,0\}..}'.
  15126. @<Put the pre-join...@>=
  15127. begin t:=scan_direction;
  15128. if t<>open then
  15129.   begin right_type(q):=t; right_given(q):=cur_exp;
  15130.   if left_type(q)=open then
  15131.     begin left_type(q):=t; left_given(q):=cur_exp;
  15132.     end; {note that |left_given(q)=left_curl(q)|}
  15133.   end;
  15134. @ Since |left_tension| and |left_y| share the same position in knot nodes,
  15135. and since |left_given| is similarly equivalent to |left_x|, we use
  15136. |x| and |y| to hold the given direction and tension information when
  15137. there are no explicit control points.
  15138. @<Put the post-join...@>=
  15139. begin t:=scan_direction;
  15140. if right_type(q)<>explicit then x:=cur_exp
  15141. else t:=explicit; {the direction information is superfluous}
  15142. @ @<Determine the tension and/or...@>=
  15143. begin get_x_next;
  15144. if cur_cmd=tension then @<Set explicit tensions@>
  15145. else if cur_cmd=controls then @<Set explicit control points@>
  15146. else  begin right_tension(q):=unity; y:=unity; back_input; {default tension}
  15147.   goto done;
  15148.   end;
  15149. if cur_cmd<>path_join then
  15150.   begin missing_err("..");@/
  15151. @.Missing `..'@>
  15152.   help1("A path join command should end with two dots.");
  15153.   back_error;
  15154.   end;
  15155. done:end
  15156. @ @<Set explicit tensions@>=
  15157. begin get_x_next; y:=cur_cmd;
  15158. if cur_cmd=at_least then get_x_next;
  15159. scan_primary;
  15160. @<Make sure that the current expression is a valid tension setting@>;
  15161. if y=at_least then negate(cur_exp);
  15162. right_tension(q):=cur_exp;
  15163. if cur_cmd=and_command then
  15164.   begin get_x_next; y:=cur_cmd;
  15165.   if cur_cmd=at_least then get_x_next;
  15166.   scan_primary;
  15167.   @<Make sure that the current expression is a valid tension setting@>;
  15168.   if y=at_least then negate(cur_exp);
  15169.   end;
  15170. y:=cur_exp;
  15171. @ @d min_tension==three_quarter_unit
  15172. @<Make sure that the current expression is a valid tension setting@>=
  15173. if (cur_type<>known)or(cur_exp<min_tension) then
  15174.   begin exp_err("Improper tension has been set to 1");
  15175. @.Improper tension@>
  15176.   help1("The expression above should have been a number >=3/4.");
  15177.   put_get_flush_error(unity);
  15178.   end
  15179. @ @<Set explicit control points@>=
  15180. begin right_type(q):=explicit; t:=explicit; get_x_next; scan_primary;@/
  15181. known_pair; right_x(q):=cur_x; right_y(q):=cur_y;
  15182. if cur_cmd<>and_command then
  15183.   begin x:=right_x(q); y:=right_y(q);
  15184.   end
  15185. else  begin get_x_next; scan_primary;@/
  15186.   known_pair; x:=cur_x; y:=cur_y;
  15187.   end;
  15188. @ @<Convert the right operand, |cur_exp|, into a partial path...@>=
  15189. begin if cur_type<>path_type then pp:=new_knot
  15190. else pp:=cur_exp;
  15191. qq:=pp;
  15192. while link(qq)<>pp do qq:=link(qq);
  15193. if left_type(pp)<>endpoint then {open up a cycle}
  15194.   begin r:=copy_knot(pp); link(qq):=r; qq:=r;
  15195.   end;
  15196. left_type(pp):=open; right_type(qq):=open;
  15197. @ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}',
  15198. we silently change the specification to `\.{(x,y)..cycle}', since a cycle
  15199. shouldn't have length zero.
  15200. @<Get ready to close a cycle@>=
  15201. begin cycle_hit:=true; get_x_next; pp:=p; qq:=p;
  15202. if d=ampersand then if p=q then
  15203.   begin d:=path_join; right_tension(q):=unity; y:=unity;
  15204.   end;
  15205. @ @<Join the partial paths and reset |p| and |q|...@>=
  15206. begin if d=ampersand then
  15207.  if (x_coord(q)<>x_coord(pp))or(y_coord(q)<>y_coord(pp)) then
  15208.   begin print_err("Paths don't touch; `&' will be changed to `..'");
  15209. @.Paths don't touch@>
  15210.   help3("When you join paths `p&q', the ending point of p")@/
  15211.     ("must be exactly equal to the starting point of q.")@/
  15212.     ("So I'm going to pretend that you said `p..q' instead.");
  15213.   put_get_error; d:=path_join; right_tension(q):=unity; y:=unity;
  15214.   end;
  15215. @<Plug an opening in |right_type(pp)|, if possible@>;
  15216. if d=ampersand then @<Splice independent paths together@>
  15217. else  begin @<Plug an opening in |right_type(q)|, if possible@>;
  15218.   link(q):=pp; left_y(pp):=y;
  15219.   if t<>open then
  15220.     begin left_x(pp):=x; left_type(pp):=t;
  15221.     end;
  15222.   end;
  15223. q:=qq;
  15224. @ @<Plug an opening in |right_type(q)|...@>=
  15225. if right_type(q)=open then
  15226.   if (left_type(q)=curl)or(left_type(q)=given) then
  15227.     begin right_type(q):=left_type(q); right_given(q):=left_given(q);
  15228.     end
  15229. @ @<Plug an opening in |right_type(pp)|...@>=
  15230. if right_type(pp)=open then
  15231.   if (t=curl)or(t=given) then
  15232.     begin right_type(pp):=t; right_given(pp):=x;
  15233.     end
  15234. @ @<Splice independent paths together@>=
  15235. begin if left_type(q)=open then if right_type(q)=open then
  15236.     begin left_type(q):=curl; left_curl(q):=unity;
  15237.     end;
  15238. if right_type(pp)=open then if t=open then
  15239.   begin right_type(pp):=curl; right_curl(pp):=unity;
  15240.   end;
  15241. right_type(q):=right_type(pp); link(q):=link(pp);@/
  15242. right_x(q):=right_x(pp); right_y(q):=right_y(pp);
  15243. free_node(pp,knot_node_size);
  15244. if qq=pp then qq:=q;
  15245. @ @<Choose control points for the path...@>=
  15246. if cycle_hit then
  15247.   begin if d=ampersand then p:=q;
  15248.   end
  15249. else  begin left_type(p):=endpoint;
  15250.   if right_type(p)=open then
  15251.     begin right_type(p):=curl; right_curl(p):=unity;
  15252.     end;
  15253.   right_type(q):=endpoint;
  15254.   if left_type(q)=open then
  15255.     begin left_type(q):=curl; left_curl(q):=unity;
  15256.     end;
  15257.   link(q):=p;
  15258.   end;
  15259. make_choices(p);
  15260. cur_type:=path_type; cur_exp:=p
  15261. @ Finally, we sometimes need to scan an expression whose value is
  15262. supposed to be either |true_code| or |false_code|.
  15263. @<Declare the basic parsing subroutines@>=
  15264. procedure get_boolean;
  15265. begin get_x_next; scan_expression;
  15266. if cur_type<>boolean_type then
  15267.   begin exp_err("Undefined condition will be treated as `false'");
  15268. @.Undefined condition...@>
  15269.   help2("The expression shown above should have had a definite")@/
  15270.     ("true-or-false value. I'm changing it to `false'.");@/
  15271.   put_get_flush_error(false_code); cur_type:=boolean_type;
  15272.   end;
  15273. @* \[42] Doing the operations.
  15274. The purpose of parsing is primarily to permit people to avoid piles of
  15275. parentheses. But the real work is done after the structure of an expression
  15276. has been recognized; that's when new expressions are generated. We
  15277. turn now to the guts of \MF, which handles individual operators that
  15278. have come through the parsing mechanism.
  15279. We'll start with the easy ones that take no operands, then work our way
  15280. up to operators with one and ultimately two arguments. In other words,
  15281. we will write the three procedures |do_nullary|, |do_unary|, and |do_binary|
  15282. that are invoked periodically by the expression scanners.
  15283. First let's make sure that all of the primitive operators are in the
  15284. hash table. Although |scan_primary| and its relatives made use of the
  15285. \\{cmd} code for these operators, the \\{do} routines base everything
  15286. on the \\{mod} code. For example, |do_binary| doesn't care whether the
  15287. operation it performs is a |primary_binary| or |secondary_binary|, etc.
  15288. @<Put each...@>=
  15289. primitive("true",nullary,true_code);@/
  15290. @!@:true_}{\&{true} primitive@>
  15291. primitive("false",nullary,false_code);@/
  15292. @!@:false_}{\&{false} primitive@>
  15293. primitive("nullpicture",nullary,null_picture_code);@/
  15294. @!@:null_picture_}{\&{nullpicture} primitive@>
  15295. primitive("nullpen",nullary,null_pen_code);@/
  15296. @!@:null_pen_}{\&{nullpen} primitive@>
  15297. primitive("jobname",nullary,job_name_op);@/
  15298. @!@:job_name_}{\&{jobname} primitive@>
  15299. primitive("readstring",nullary,read_string_op);@/
  15300. @!@:read_string_}{\&{readstring} primitive@>
  15301. primitive("pencircle",nullary,pen_circle);@/
  15302. @!@:pen_circle_}{\&{pencircle} primitive@>
  15303. primitive("normaldeviate",nullary,normal_deviate);@/
  15304. @!@:normal_deviate_}{\&{normaldeviate} primitive@>
  15305. primitive("odd",unary,odd_op);@/
  15306. @!@:odd_}{\&{odd} primitive@>
  15307. primitive("known",unary,known_op);@/
  15308. @!@:known_}{\&{known} primitive@>
  15309. primitive("unknown",unary,unknown_op);@/
  15310. @!@:unknown_}{\&{unknown} primitive@>
  15311. primitive("not",unary,not_op);@/
  15312. @!@:not_}{\&{not} primitive@>
  15313. primitive("decimal",unary,decimal);@/
  15314. @!@:decimal_}{\&{decimal} primitive@>
  15315. primitive("reverse",unary,reverse);@/
  15316. @!@:reverse_}{\&{reverse} primitive@>
  15317. primitive("makepath",unary,make_path_op);@/
  15318. @!@:make_path_}{\&{makepath} primitive@>
  15319. primitive("makepen",unary,make_pen_op);@/
  15320. @!@:make_pen_}{\&{makepen} primitive@>
  15321. primitive("totalweight",unary,total_weight_op);@/
  15322. @!@:total_weight_}{\&{totalweight} primitive@>
  15323. primitive("oct",unary,oct_op);@/
  15324. @!@:oct_}{\&{oct} primitive@>
  15325. primitive("hex",unary,hex_op);@/
  15326. @!@:hex_}{\&{hex} primitive@>
  15327. primitive("ASCII",unary,ASCII_op);@/
  15328. @!@:ASCII_}{\&{ASCII} primitive@>
  15329. primitive("char",unary,char_op);@/
  15330. @!@:char_}{\&{char} primitive@>
  15331. primitive("length",unary,length_op);@/
  15332. @!@:length_}{\&{length} primitive@>
  15333. primitive("turningnumber",unary,turning_op);@/
  15334. @!@:turning_number_}{\&{turningnumber} primitive@>
  15335. primitive("xpart",unary,x_part);@/
  15336. @!@:x_part_}{\&{xpart} primitive@>
  15337. primitive("ypart",unary,y_part);@/
  15338. @!@:y_part_}{\&{ypart} primitive@>
  15339. primitive("xxpart",unary,xx_part);@/
  15340. @!@:xx_part_}{\&{xxpart} primitive@>
  15341. primitive("xypart",unary,xy_part);@/
  15342. @!@:xy_part_}{\&{xypart} primitive@>
  15343. primitive("yxpart",unary,yx_part);@/
  15344. @!@:yx_part_}{\&{yxpart} primitive@>
  15345. primitive("yypart",unary,yy_part);@/
  15346. @!@:yy_part_}{\&{yypart} primitive@>
  15347. primitive("sqrt",unary,sqrt_op);@/
  15348. @!@:sqrt_}{\&{sqrt} primitive@>
  15349. primitive("mexp",unary,m_exp_op);@/
  15350. @!@:m_exp_}{\&{mexp} primitive@>
  15351. primitive("mlog",unary,m_log_op);@/
  15352. @!@:m_log_}{\&{mlog} primitive@>
  15353. primitive("sind",unary,sin_d_op);@/
  15354. @!@:sin_d_}{\&{sind} primitive@>
  15355. primitive("cosd",unary,cos_d_op);@/
  15356. @!@:cos_d_}{\&{cosd} primitive@>
  15357. primitive("floor",unary,floor_op);@/
  15358. @!@:floor_}{\&{floor} primitive@>
  15359. primitive("uniformdeviate",unary,uniform_deviate);@/
  15360. @!@:uniform_deviate_}{\&{uniformdeviate} primitive@>
  15361. primitive("charexists",unary,char_exists_op);@/
  15362. @!@:char_exists_}{\&{charexists} primitive@>
  15363. primitive("angle",unary,angle_op);@/
  15364. @!@:angle_}{\&{angle} primitive@>
  15365. primitive("cycle",cycle,cycle_op);@/
  15366. @!@:cycle_}{\&{cycle} primitive@>
  15367. primitive("+",plus_or_minus,plus);@/
  15368. @!@:+ }{\.{+} primitive@>
  15369. primitive("-",plus_or_minus,minus);@/
  15370. @!@:- }{\.{-} primitive@>
  15371. primitive("*",secondary_binary,times);@/
  15372. @!@:* }{\.{*} primitive@>
  15373. primitive("/",slash,over); eqtb[frozen_slash]:=eqtb[cur_sym];@/
  15374. @!@:/ }{\.{/} primitive@>
  15375. primitive("++",tertiary_binary,pythag_add);@/
  15376. @!@:++_}{\.{++} primitive@>
  15377. primitive("+-+",tertiary_binary,pythag_sub);@/
  15378. @!@:+-+_}{\.{+-+} primitive@>
  15379. primitive("and",and_command,and_op);@/
  15380. @!@:and_}{\&{and} primitive@>
  15381. primitive("or",tertiary_binary,or_op);@/
  15382. @!@:or_}{\&{or} primitive@>
  15383. primitive("<",expression_binary,less_than);@/
  15384. @!@:< }{\.{<} primitive@>
  15385. primitive("<=",expression_binary,less_or_equal);@/
  15386. @!@:<=_}{\.{<=} primitive@>
  15387. primitive(">",expression_binary,greater_than);@/
  15388. @!@:> }{\.{>} primitive@>
  15389. primitive(">=",expression_binary,greater_or_equal);@/
  15390. @!@:>=_}{\.{>=} primitive@>
  15391. primitive("=",equals,equal_to);@/
  15392. @!@:= }{\.{=} primitive@>
  15393. primitive("<>",expression_binary,unequal_to);@/
  15394. @!@:<>_}{\.{<>} primitive@>
  15395. primitive("substring",primary_binary,substring_of);@/
  15396. @!@:substring_}{\&{substring} primitive@>
  15397. primitive("subpath",primary_binary,subpath_of);@/
  15398. @!@:subpath_}{\&{subpath} primitive@>
  15399. primitive("directiontime",primary_binary,direction_time_of);@/
  15400. @!@:direction_time_}{\&{directiontime} primitive@>
  15401. primitive("point",primary_binary,point_of);@/
  15402. @!@:point_}{\&{point} primitive@>
  15403. primitive("precontrol",primary_binary,precontrol_of);@/
  15404. @!@:precontrol_}{\&{precontrol} primitive@>
  15405. primitive("postcontrol",primary_binary,postcontrol_of);@/
  15406. @!@:postcontrol_}{\&{postcontrol} primitive@>
  15407. primitive("penoffset",primary_binary,pen_offset_of);@/
  15408. @!@:pen_offset_}{\&{penoffset} primitive@>
  15409. primitive("&",ampersand,concatenate);@/
  15410. @!@:!!!}{\.{\&} primitive@>
  15411. primitive("rotated",secondary_binary,rotated_by);@/
  15412. @!@:rotated_}{\&{rotated} primitive@>
  15413. primitive("slanted",secondary_binary,slanted_by);@/
  15414. @!@:slanted_}{\&{slanted} primitive@>
  15415. primitive("scaled",secondary_binary,scaled_by);@/
  15416. @!@:scaled_}{\&{scaled} primitive@>
  15417. primitive("shifted",secondary_binary,shifted_by);@/
  15418. @!@:shifted_}{\&{shifted} primitive@>
  15419. primitive("transformed",secondary_binary,transformed_by);@/
  15420. @!@:transformed_}{\&{transformed} primitive@>
  15421. primitive("xscaled",secondary_binary,x_scaled);@/
  15422. @!@:x_scaled_}{\&{xscaled} primitive@>
  15423. primitive("yscaled",secondary_binary,y_scaled);@/
  15424. @!@:y_scaled_}{\&{yscaled} primitive@>
  15425. primitive("zscaled",secondary_binary,z_scaled);@/
  15426. @!@:z_scaled_}{\&{zscaled} primitive@>
  15427. primitive("intersectiontimes",tertiary_binary,intersect);@/
  15428. @!@:intersection_times_}{\&{intersectiontimes} primitive@>
  15429. @ @<Cases of |print_cmd...@>=
  15430. nullary,unary,primary_binary,secondary_binary,tertiary_binary,
  15431.  expression_binary,cycle,plus_or_minus,slash,ampersand,equals,and_command:
  15432.   print_op(m);
  15433. @ OK, let's look at the simplest \\{do} procedure first.
  15434. @p procedure do_nullary(@!c:quarterword);
  15435. var @!k:integer; {all-purpose loop index}
  15436. begin check_arith;
  15437. if internal[tracing_commands]>two then
  15438.   show_cmd_mod(nullary,c);
  15439. case c of
  15440. true_code,false_code:begin cur_type:=boolean_type; cur_exp:=c;
  15441.   end;
  15442. null_picture_code:begin cur_type:=picture_type;
  15443.   cur_exp:=get_node(edge_header_size); init_edges(cur_exp);
  15444.   end;
  15445. null_pen_code:begin cur_type:=pen_type; cur_exp:=null_pen;
  15446.   end;
  15447. normal_deviate:begin cur_type:=known; cur_exp:=norm_rand;
  15448.   end;
  15449. pen_circle:@<Make a special knot node for \&{pencircle}@>;
  15450. job_name_op: begin if job_name=0 then open_log_file;
  15451.   cur_type:=string_type; cur_exp:=job_name;
  15452.   end;
  15453. read_string_op:@<Read a string from the terminal@>;
  15454. end; {there are no other cases}
  15455. check_arith;
  15456. @ @<Make a special knot node for \&{pencircle}@>=
  15457. begin cur_type:=future_pen; cur_exp:=get_node(knot_node_size);
  15458. left_type(cur_exp):=open; right_type(cur_exp):=open;
  15459. link(cur_exp):=cur_exp;@/
  15460. x_coord(cur_exp):=0; y_coord(cur_exp):=0;@/
  15461. left_x(cur_exp):=unity; left_y(cur_exp):=0;@/
  15462. right_x(cur_exp):=0; right_y(cur_exp):=unity;@/
  15463. @ @<Read a string...@>=
  15464. begin if interaction<=nonstop_mode then
  15465.   fatal_error("*** (cannot readstring in nonstop modes)");
  15466. begin_file_reading; name:=1; prompt_input("");
  15467. str_room(last-start);
  15468. for k:=start to last-1 do append_char(buffer[k]);
  15469. end_file_reading; cur_type:=string_type; cur_exp:=make_string;
  15470. @ Things get a bit more interesting when there's an operand. The
  15471. operand to |do_unary| appears in |cur_type| and |cur_exp|.
  15472. @p @t\4@>@<Declare unary action procedures@>@;
  15473. procedure do_unary(@!c:quarterword);
  15474. var @!p,@!q:pointer; {for list manipulation}
  15475. @!x:integer; {a temporary register}
  15476. begin check_arith;
  15477. if internal[tracing_commands]>two then
  15478.   @<Trace the current unary operation@>;
  15479. case c of
  15480. plus:if cur_type<pair_type then
  15481.   if cur_type<>picture_type then bad_unary(plus);
  15482. minus:@<Negate the current expression@>;
  15483. @t\4@>@<Additional cases of unary operators@>@;
  15484. end; {there are no other cases}
  15485. check_arith;
  15486. @ The |nice_pair| function returns |true| if both components of a pair
  15487. are known.
  15488. @<Declare unary action procedures@>=
  15489. function nice_pair(@!p:integer;@!t:quarterword):boolean;
  15490. label exit;
  15491. begin if t=pair_type then
  15492.   begin p:=value(p);
  15493.   if type(x_part_loc(p))=known then
  15494.    if type(y_part_loc(p))=known then
  15495.     begin nice_pair:=true; return;
  15496.     end;
  15497.   end;
  15498. nice_pair:=false;
  15499. exit:end;
  15500. @ @<Declare unary action...@>=
  15501. procedure print_known_or_unknown_type(@!t:small_number;@!v:integer);
  15502. begin print_char("(");
  15503. if t<dependent then
  15504.   if t<>pair_type then print_type(t)
  15505.   else if nice_pair(v,pair_type) then print("pair")
  15506.   else print("unknown pair")
  15507. else print("unknown numeric");
  15508. print_char(")");
  15509. @ @<Declare unary action...@>=
  15510. procedure bad_unary(@!c:quarterword);
  15511. begin exp_err("Not implemented: "); print_op(c);
  15512. @.Not implemented...@>
  15513. print_known_or_unknown_type(cur_type,cur_exp);
  15514. help3("I'm afraid I don't know how to apply that operation to that")@/
  15515.   ("particular type. Continue, and I'll simply return the")@/
  15516.   ("argument (shown above) as the result of the operation.");
  15517. put_get_error;
  15518. @ @<Trace the current unary operation@>=
  15519. begin begin_diagnostic; print_nl("{"); print_op(c); print_char("(");@/
  15520. print_exp(null,0); {show the operand, but not verbosely}
  15521. print(")}"); end_diagnostic(false);
  15522. @ Negation is easy except when the current expression
  15523. is of type |independent|, or when it is a pair with one or more
  15524. |independent| components.
  15525. It is tempting to argue that the negative of an independent variable
  15526. is an independent variable, hence we don't have to do anything when
  15527. negating it. The fallacy is that other dependent variables pointing
  15528. to the current expression must change the sign of their
  15529. coefficients if we make no change to the current expression.
  15530. Instead, we work around the problem by copying the current expression
  15531. and recycling it afterwards (cf.~the |stash_in| routine).
  15532. @<Negate the current expression@>=
  15533. case cur_type of
  15534. pair_type,independent: begin q:=cur_exp; make_exp_copy(q);
  15535.   if cur_type=dependent then negate_dep_list(dep_list(cur_exp))
  15536.   else if cur_type=pair_type then
  15537.     begin p:=value(cur_exp);
  15538.     if type(x_part_loc(p))=known then negate(value(x_part_loc(p)))
  15539.     else negate_dep_list(dep_list(x_part_loc(p)));
  15540.     if type(y_part_loc(p))=known then negate(value(y_part_loc(p)))
  15541.     else negate_dep_list(dep_list(y_part_loc(p)));
  15542.     end; {if |cur_type=known| then |cur_exp=0|}
  15543.   recycle_value(q); free_node(q,value_node_size);
  15544.   end;
  15545. dependent,proto_dependent:negate_dep_list(dep_list(cur_exp));
  15546. known:negate(cur_exp);
  15547. picture_type:negate_edges(cur_exp);
  15548. othercases bad_unary(minus)
  15549. endcases
  15550. @ @<Declare unary action...@>=
  15551. procedure negate_dep_list(@!p:pointer);
  15552. label exit;
  15553. begin loop@+begin negate(value(p));
  15554.   if info(p)=null then return;
  15555.   p:=link(p);
  15556.   end;
  15557. exit:end;
  15558. @ @<Additional cases of unary operators@>=
  15559. not_op: if cur_type<>boolean_type then bad_unary(not_op)
  15560.   else cur_exp:=true_code+false_code-cur_exp;
  15561. @ @d three_sixty_units==23592960 {that's |360*unity|}
  15562. @d boolean_reset(#)==if # then cur_exp:=true_code@+else cur_exp:=false_code
  15563. @<Additional cases of unary operators@>=
  15564. sqrt_op,m_exp_op,m_log_op,sin_d_op,cos_d_op,floor_op,
  15565.  uniform_deviate,odd_op,char_exists_op:@t@>@;@/
  15566.   if cur_type<>known then bad_unary(c)
  15567.   else case c of
  15568.   sqrt_op:cur_exp:=square_rt(cur_exp);
  15569.   m_exp_op:cur_exp:=m_exp(cur_exp);
  15570.   m_log_op:cur_exp:=m_log(cur_exp);
  15571.   sin_d_op,cos_d_op:begin n_sin_cos((cur_exp mod three_sixty_units)*16);
  15572.     if c=sin_d_op then cur_exp:=round_fraction(n_sin)
  15573.     else cur_exp:=round_fraction(n_cos);
  15574.     end;
  15575.   floor_op:cur_exp:=floor_scaled(cur_exp);
  15576.   uniform_deviate:cur_exp:=unif_rand(cur_exp);
  15577.   odd_op: begin boolean_reset(odd(round_unscaled(cur_exp)));
  15578.     cur_type:=boolean_type;
  15579.     end;
  15580.   char_exists_op:@<Determine if a character has been shipped out@>;
  15581.   end; {there are no other cases}
  15582. @ @<Additional cases of unary operators@>=
  15583. angle_op:if nice_pair(cur_exp,cur_type) then
  15584.     begin p:=value(cur_exp);
  15585.     x:=n_arg(value(x_part_loc(p)),value(y_part_loc(p)));
  15586.     if x>=0 then flush_cur_exp((x+8)div 16)
  15587.     else flush_cur_exp(-((-x+8)div 16));
  15588.     end
  15589.   else bad_unary(angle_op);
  15590. @ If the current expression is a pair, but the context wants it to
  15591. be a path, we call |pair_to_path|.
  15592. @<Declare unary action...@>=
  15593. procedure pair_to_path;
  15594. begin cur_exp:=new_knot; cur_type:=path_type;
  15595. @ @<Additional cases of unary operators@>=
  15596. x_part,y_part:if (cur_type<=pair_type)and(cur_type>=transform_type) then
  15597.     take_part(c)
  15598.   else bad_unary(c);
  15599. xx_part,xy_part,yx_part,yy_part: if cur_type=transform_type then take_part(c)
  15600.   else bad_unary(c);
  15601. @ In the following procedure, |cur_exp| points to a capsule, which points to
  15602. a big node. We want to delete all but one part of the big node.
  15603. @<Declare unary action...@>=
  15604. procedure take_part(@!c:quarterword);
  15605. var @!p:pointer; {the big node}
  15606. begin p:=value(cur_exp); value(temp_val):=p; type(temp_val):=cur_type;
  15607. link(p):=temp_val; free_node(cur_exp,value_node_size);
  15608. make_exp_copy(p+2*(c-x_part));
  15609. recycle_value(temp_val);
  15610. @ @<Initialize table entries...@>=
  15611. name_type(temp_val):=capsule;
  15612. @ @<Additional cases of unary...@>=
  15613. char_op: if cur_type<>known then bad_unary(char_op)
  15614.   else  begin cur_exp:=round_unscaled(cur_exp) mod 256; cur_type:=string_type;
  15615.     if cur_exp<0 then cur_exp:=cur_exp+256;
  15616.     if length(cur_exp)<>1 then
  15617.       begin str_room(1); append_char(cur_exp); cur_exp:=make_string;
  15618.       end;
  15619.     end;
  15620. decimal: if cur_type<>known then bad_unary(decimal)
  15621.   else  begin old_setting:=selector; selector:=new_string;
  15622.     print_scaled(cur_exp); cur_exp:=make_string;
  15623.     selector:=old_setting; cur_type:=string_type;
  15624.     end;
  15625. oct_op,hex_op,ASCII_op: if cur_type<>string_type then bad_unary(c)
  15626.   else str_to_num(c);
  15627. @ @<Declare unary action...@>=
  15628. procedure str_to_num(@!c:quarterword); {converts a string to a number}
  15629. var @!n:integer; {accumulator}
  15630. @!m:ASCII_code; {current character}
  15631. @!k:pool_pointer; {index into |str_pool|}
  15632. @!b:8..16; {radix of conversion}
  15633. @!bad_char:boolean; {did the string contain an invalid digit?}
  15634. begin if c=ASCII_op then
  15635.   if length(cur_exp)=0 then n:=-1
  15636.   else n:=so(str_pool[str_start[cur_exp]])
  15637. else  begin if c=oct_op then b:=8@+else b:=16;
  15638.   n:=0; bad_char:=false;
  15639.   for k:=str_start[cur_exp] to str_start[cur_exp+1]-1 do
  15640.     begin m:=so(str_pool[k]);
  15641.     if (m>="0")and(m<="9") then m:=m-"0"
  15642.     else if (m>="A")and(m<="F") then m:=m-"A"+10
  15643.     else if (m>="a")and(m<="f") then m:=m-"a"+10
  15644.     else  begin bad_char:=true; m:=0;
  15645.       end;
  15646.     if m>=b then
  15647.       begin bad_char:=true; m:=0;
  15648.       end;
  15649.     if n<32768 div b then n:=n*b+m@+else n:=32767;
  15650.     end;
  15651.   @<Give error messages if |bad_char| or |n>=4096|@>;
  15652.   end;
  15653. flush_cur_exp(n*unity);
  15654. @ @<Give error messages if |bad_char|...@>=
  15655. if bad_char then
  15656.   begin exp_err("String contains illegal digits");
  15657. @.String contains illegal digits@>
  15658.   if c=oct_op then
  15659.     help1("I zeroed out characters that weren't in the range 0..7.")
  15660.   else help1("I zeroed out characters that weren't hex digits.");
  15661.   put_get_error;
  15662.   end;
  15663. if n>4095 then
  15664.   begin print_err("Number too large ("); print_int(n); print_char(")");
  15665. @.Number too large@>
  15666.   help1("I have trouble with numbers greater than 4095; watch out.");
  15667.   put_get_error;
  15668.   end
  15669. @ The length operation is somewhat unusual in that it applies to a variety
  15670. of different types of operands.
  15671. @<Additional cases of unary...@>=
  15672. length_op: if cur_type=string_type then flush_cur_exp(length(cur_exp)*unity)
  15673.   else if cur_type=path_type then flush_cur_exp(path_length)
  15674.   else if cur_type=known then cur_exp:=abs(cur_exp)
  15675.   else if nice_pair(cur_exp,cur_type) then
  15676.     flush_cur_exp(pyth_add(value(x_part_loc(value(cur_exp))),@|
  15677.       value(y_part_loc(value(cur_exp)))))
  15678.   else bad_unary(c);
  15679. @ @<Declare unary action...@>=
  15680. function path_length:scaled; {computes the length of the current path}
  15681. var @!n:scaled; {the path length so far}
  15682. @!p:pointer; {traverser}
  15683. begin p:=cur_exp;
  15684. if left_type(p)=endpoint then n:=-unity@+else n:=0;
  15685. repeat p:=link(p); n:=n+unity;
  15686. until p=cur_exp;
  15687. path_length:=n;
  15688. @ The turning number is computed only with respect to null pens. A different
  15689. pen might affect the turning number, in degenerate cases, because autorounding
  15690. will produce a slightly different path, or because excessively large coordinates
  15691. might be truncated.
  15692. @<Additional cases of unary...@>=
  15693. turning_op:if cur_type=pair_type then flush_cur_exp(0)
  15694.   else if cur_type<>path_type then bad_unary(turning_op)
  15695.   else if left_type(cur_exp)=endpoint then
  15696.      flush_cur_exp(0) {not a cyclic path}
  15697.   else  begin cur_pen:=null_pen; cur_path_type:=contour_code;
  15698.     cur_exp:=make_spec(cur_exp,
  15699.       fraction_one-half_unit-1-el_gordo,0);
  15700.     flush_cur_exp(turning_number*unity); {convert to |scaled|}
  15701.     end;
  15702. @ @d type_test_end== flush_cur_exp(true_code)
  15703.   else flush_cur_exp(false_code);
  15704.   cur_type:=boolean_type;
  15705.   end
  15706. @d type_range_end(#)==(cur_type<=#) then type_test_end
  15707. @d type_range(#)==begin if (cur_type>=#) and type_range_end
  15708. @d type_test(#)==begin if cur_type=# then type_test_end
  15709. @<Additional cases of unary operators@>=
  15710. boolean_type: type_range(boolean_type)(unknown_boolean);
  15711. string_type: type_range(string_type)(unknown_string);
  15712. pen_type: type_range(pen_type)(future_pen);
  15713. path_type: type_range(path_type)(unknown_path);
  15714. picture_type: type_range(picture_type)(unknown_picture);
  15715. transform_type,pair_type: type_test(c);
  15716. numeric_type: type_range(known)(independent);
  15717. known_op,unknown_op: test_known(c);
  15718. @ @<Declare unary action procedures@>=
  15719. procedure test_known(@!c:quarterword);
  15720. label done;
  15721. var @!b:true_code..false_code; {is the current expression known?}
  15722. @!p,@!q:pointer; {locations in a big node}
  15723. begin b:=false_code;
  15724. case cur_type of
  15725. vacuous,boolean_type,string_type,pen_type,future_pen,path_type,picture_type,
  15726.  known: b:=true_code;
  15727. transform_type,pair_type:begin p:=value(cur_exp); q:=p+big_node_size[cur_type];
  15728.   repeat q:=q-2;
  15729.   if type(q)<>known then goto done;
  15730.   until q=p;
  15731.   b:=true_code;
  15732. done:  end;
  15733. othercases do_nothing
  15734. endcases;
  15735. if c=known_op then flush_cur_exp(b)
  15736. else flush_cur_exp(true_code+false_code-b);
  15737. cur_type:=boolean_type;
  15738. @ @<Additional cases of unary operators@>=
  15739. cycle_op: begin if cur_type<>path_type then flush_cur_exp(false_code)
  15740.   else if left_type(cur_exp)<>endpoint then flush_cur_exp(true_code)
  15741.   else flush_cur_exp(false_code);
  15742.   cur_type:=boolean_type;
  15743.   end;
  15744. @ @<Additional cases of unary operators@>=
  15745. make_pen_op: begin if cur_type=pair_type then pair_to_path;
  15746.   if cur_type=path_type then cur_type:=future_pen
  15747.   else bad_unary(make_pen_op);
  15748.   end;
  15749. make_path_op: begin if cur_type=future_pen then materialize_pen;
  15750.   if cur_type<>pen_type then bad_unary(make_path_op)
  15751.   else  begin flush_cur_exp(make_path(cur_exp)); cur_type:=path_type;
  15752.     end;
  15753.   end;
  15754. total_weight_op: if cur_type<>picture_type then bad_unary(total_weight_op)
  15755.   else flush_cur_exp(total_weight(cur_exp));
  15756. reverse: if cur_type=path_type then
  15757.     begin p:=htap_ypoc(cur_exp);
  15758.     if right_type(p)=endpoint then p:=link(p);
  15759.     toss_knot_list(cur_exp); cur_exp:=p;
  15760.     end
  15761.   else if cur_type=pair_type then pair_to_path
  15762.   else bad_unary(reverse);
  15763. @ Finally, we have the operations that combine a capsule~|p|
  15764. with the current expression.
  15765. @p @t\4@>@<Declare binary action procedures@>@;
  15766. procedure do_binary(@!p:pointer;@!c:quarterword);
  15767. label done,done1,exit;
  15768. var @!q,@!r,@!rr:pointer; {for list manipulation}
  15769. @!old_p,@!old_exp:pointer; {capsules to recycle}
  15770. @!v:integer; {for numeric manipulation}
  15771. begin check_arith;
  15772. if internal[tracing_commands]>two then
  15773.   @<Trace the current binary operation@>;
  15774. @<Sidestep |independent| cases in capsule |p|@>;
  15775. @<Sidestep |independent| cases in the current expression@>;
  15776. case c of
  15777. plus,minus:@<Add or subtract the current expression from |p|@>;
  15778. @t\4@>@<Additional cases of binary operators@>@;
  15779. end; {there are no other cases}
  15780. recycle_value(p); free_node(p,value_node_size); {|return| to avoid this}
  15781. exit:check_arith; @<Recycle any sidestepped |independent| capsules@>;
  15782. @ @<Declare binary action...@>=
  15783. procedure bad_binary(@!p:pointer;@!c:quarterword);
  15784. begin disp_err(p,"");
  15785. exp_err("Not implemented: ");
  15786. @.Not implemented...@>
  15787. if c>=min_of then print_op(c);
  15788. print_known_or_unknown_type(type(p),p);
  15789. if c>=min_of then print("of")@+else print_op(c);
  15790. print_known_or_unknown_type(cur_type,cur_exp);@/
  15791. help3("I'm afraid I don't know how to apply that operation to that")@/
  15792.   ("combination of types. Continue, and I'll return the second")@/
  15793.   ("argument (see above) as the result of the operation.");
  15794. put_get_error;
  15795. @ @<Trace the current binary operation@>=
  15796. begin begin_diagnostic; print_nl("{(");
  15797. print_exp(p,0); {show the operand, but not verbosely}
  15798. print_char(")"); print_op(c); print_char("(");@/
  15799. print_exp(null,0); print(")}"); end_diagnostic(false);
  15800. @ Several of the binary operations are potentially complicated by the
  15801. fact that |independent| values can sneak into capsules. For example,
  15802. we've seen an instance of this difficulty in the unary operation
  15803. of negation. In order to reduce the number of cases that need to be
  15804. handled, we first change the two operands (if necessary)
  15805. to rid them of |independent| components. The original operands are
  15806. put into capsules called |old_p| and |old_exp|, which will be
  15807. recycled after the binary operation has been safely carried out.
  15808. @<Recycle any sidestepped |independent| capsules@>=
  15809. if old_p<>null then
  15810.   begin recycle_value(old_p); free_node(old_p,value_node_size);
  15811.   end;
  15812. if old_exp<>null then
  15813.   begin recycle_value(old_exp); free_node(old_exp,value_node_size);
  15814.   end
  15815. @ A big node is considered to be ``tarnished'' if it contains at least one
  15816. independent component. We will define a simple function called `|tarnished|'
  15817. that returns |null| if and only if its argument is not tarnished.
  15818. @<Sidestep |independent| cases in capsule |p|@>=
  15819. case type(p) of
  15820. transform_type,pair_type: old_p:=tarnished(p);
  15821. independent: old_p:=void;
  15822. othercases old_p:=null
  15823. endcases;
  15824. if old_p<>null then
  15825.   begin q:=stash_cur_exp; old_p:=p; make_exp_copy(old_p);
  15826.   p:=stash_cur_exp; unstash_cur_exp(q);
  15827.   end;
  15828. @ @<Sidestep |independent| cases in the current expression@>=
  15829. case cur_type of
  15830. transform_type,pair_type:old_exp:=tarnished(cur_exp);
  15831. independent:old_exp:=void;
  15832. othercases old_exp:=null
  15833. endcases;
  15834. if old_exp<>null then
  15835.   begin old_exp:=cur_exp; make_exp_copy(old_exp);
  15836.   end
  15837. @ @<Declare binary action...@>=
  15838. function tarnished(@!p:pointer):pointer;
  15839. label exit;
  15840. var @!q:pointer; {beginning of the big node}
  15841. @!r:pointer; {current position in the big node}
  15842. begin q:=value(p); r:=q+big_node_size[type(p)];
  15843. repeat r:=r-2;
  15844. if type(r)=independent then
  15845.   begin tarnished:=void; return;
  15846.   end;
  15847. until r=q;
  15848. tarnished:=null;
  15849. exit:end;
  15850. @ @<Add or subtract the current expression from |p|@>=
  15851. if (cur_type<pair_type)or(type(p)<pair_type) then
  15852.   if (cur_type=picture_type)and(type(p)=picture_type) then
  15853.     begin if c=minus then negate_edges(cur_exp);
  15854.     cur_edges:=cur_exp; merge_edges(value(p));
  15855.     end
  15856.   else bad_binary(p,c)
  15857. else  if cur_type=pair_type then
  15858.     if type(p)<>pair_type then bad_binary(p,c)
  15859.     else  begin q:=value(p); r:=value(cur_exp);
  15860.       add_or_subtract(x_part_loc(q),x_part_loc(r),c);
  15861.       add_or_subtract(y_part_loc(q),y_part_loc(r),c);
  15862.       end
  15863.   else  if type(p)=pair_type then bad_binary(p,c)
  15864.     else add_or_subtract(p,null,c)
  15865. @ The first argument to |add_or_subtract| is the location of a value node
  15866. in a capsule or pair node that will soon be recycled. The second argument
  15867. is either a location within a pair or transform node of |cur_exp|,
  15868. or it is null (which means that |cur_exp| itself should be the second
  15869. argument).  The third argument is either |plus| or |minus|.
  15870. The sum or difference of the numeric quantities will replace the second
  15871. operand.  Arithmetic overflow may go undetected; users aren't supposed to
  15872. be monkeying around with really big values.
  15873. @<Declare binary action...@>=
  15874. @t\4@>@<Declare the procedure called |dep_finish|@>@;
  15875. procedure add_or_subtract(@!p,@!q:pointer;@!c:quarterword);
  15876. label done,exit;
  15877. var @!s,@!t:small_number; {operand types}
  15878. @!r:pointer; {list traverser}
  15879. @!v:integer; {second operand value}
  15880. begin if q=null then
  15881.   begin t:=cur_type;
  15882.   if t<dependent then v:=cur_exp@+else v:=dep_list(cur_exp);
  15883.   end
  15884. else  begin t:=type(q);
  15885.   if t<dependent then v:=value(q)@+else v:=dep_list(q);
  15886.   end;
  15887. if t=known then
  15888.   begin if c=minus then negate(v);
  15889.   if type(p)=known then
  15890.     begin v:=slow_add(value(p),v);
  15891.     if q=null then cur_exp:=v@+else value(q):=v;
  15892.     return;
  15893.     end;
  15894.   @<Add a known value to the constant term of |dep_list(p)|@>;
  15895.   end
  15896. else  begin if c=minus then negate_dep_list(v);
  15897.   @<Add operand |p| to the dependency list |v|@>;
  15898.   end;
  15899. exit:end;
  15900. @ @<Add a known value to the constant term of |dep_list(p)|@>=
  15901. r:=dep_list(p);
  15902. while info(r)<>null do r:=link(r);
  15903. value(r):=slow_add(value(r),v);
  15904. if q=null then
  15905.   begin q:=get_node(value_node_size); cur_exp:=q; cur_type:=type(p);
  15906.   name_type(q):=capsule;
  15907.   end;
  15908. dep_list(q):=dep_list(p); type(q):=type(p);
  15909. prev_dep(q):=prev_dep(p); link(prev_dep(p)):=q;
  15910. type(p):=known; {this will keep the recycler from collecting non-garbage}
  15911. @ We prefer |dependent| lists to |proto_dependent| ones, because it is
  15912. nice to retain the extra accuracy of |fraction| coefficients.
  15913. But we have to handle both kinds, and mixtures too.
  15914. @<Add operand |p| to the dependency list |v|@>=
  15915. if type(p)=known then
  15916.   @<Add the known |value(p)| to the constant term of |v|@>
  15917. else  begin s:=type(p); r:=dep_list(p);
  15918.   if t=dependent then
  15919.     begin if s=dependent then
  15920.      if max_coef(r)+max_coef(v)<coef_bound then
  15921.       begin v:=p_plus_q(v,r,dependent); goto done;
  15922.       end; {|fix_needed| will necessarily be false}
  15923.     t:=proto_dependent; v:=p_over_v(v,unity,dependent,proto_dependent);
  15924.     end;
  15925.   if s=proto_dependent then v:=p_plus_q(v,r,proto_dependent)
  15926.   else v:=p_plus_fq(v,unity,r,proto_dependent,dependent);
  15927.  done:  @<Output the answer, |v| (which might have become |known|)@>;
  15928.   end
  15929. @ @<Add the known |value(p)| to the constant term of |v|@>=
  15930. begin while info(v)<>null do v:=link(v);
  15931. value(v):=slow_add(value(p),value(v));
  15932. @ @<Output the answer, |v| (which might have become |known|)@>=
  15933. if q<>null then dep_finish(v,q,t)
  15934. else  begin cur_type:=t; dep_finish(v,null,t);
  15935.   end
  15936. @ Here's the current situation: The dependency list |v| of type |t|
  15937. should either be put into the current expression (if |q=null|) or
  15938. into location |q| within a pair node (otherwise). The destination (|cur_exp|
  15939. or |q|) formerly held a dependency list with the same
  15940. final pointer as the list |v|.
  15941. @<Declare the procedure called |dep_finish|@>=
  15942. procedure dep_finish(@!v,@!q:pointer;@!t:small_number);
  15943. var @!p:pointer; {the destination}
  15944. @!vv:scaled; {the value, if it is |known|}
  15945. begin if q=null then p:=cur_exp@+else p:=q;
  15946. dep_list(p):=v; type(p):=t;
  15947. if info(v)=null then
  15948.   begin vv:=value(v);
  15949.   if q=null then flush_cur_exp(vv)
  15950.   else  begin recycle_value(p); type(q):=known; value(q):=vv;
  15951.     end;
  15952.   end
  15953. else if q=null then cur_type:=t;
  15954. if fix_needed then fix_dependencies;
  15955. @ Let's turn now to the six basic relations of comparison.
  15956. @<Additional cases of binary operators@>=
  15957. less_than,less_or_equal,greater_than,greater_or_equal,equal_to,unequal_to:
  15958.   begin@t@>@;
  15959.   if (cur_type>pair_type)and(type(p)>pair_type) then
  15960.     add_or_subtract(p,null,minus) {|cur_exp:=(p)-cur_exp|}
  15961.   else if cur_type<>type(p) then
  15962.     begin bad_binary(p,c); goto done;
  15963.     end
  15964.   else if cur_type=string_type then
  15965.     flush_cur_exp(str_vs_str(value(p),cur_exp))
  15966.   else if (cur_type=unknown_string)or(cur_type=unknown_boolean) then
  15967.     @<Check if unknowns have been equated@>
  15968.   else if (cur_type=pair_type)or(cur_type=transform_type) then
  15969.     @<Reduce comparison of big nodes to comparison of scalars@>
  15970.   else if cur_type=boolean_type then flush_cur_exp(cur_exp-value(p))
  15971.   else  begin bad_binary(p,c); goto done;
  15972.     end;
  15973.   @<Compare the current expression with zero@>;
  15974. done:  end;
  15975. @ @<Compare the current expression with zero@>=
  15976. if cur_type<>known then
  15977.   begin if cur_type<known then
  15978.     begin disp_err(p,"");
  15979.     help1("The quantities shown above have not been equated.")@/
  15980.     end
  15981.   else  help2("Oh dear. I can't decide if the expression above is positive,")@/
  15982.     ("negative, or zero. So this comparison test won't be `true'.");
  15983.   exp_err("Unknown relation will be considered false");
  15984. @.Unknown relation...@>
  15985.   put_get_flush_error(false_code);
  15986.   end
  15987. else case c of
  15988.   less_than: boolean_reset(cur_exp<0);
  15989.   less_or_equal: boolean_reset(cur_exp<=0);
  15990.   greater_than: boolean_reset(cur_exp>0);
  15991.   greater_or_equal: boolean_reset(cur_exp>=0);
  15992.   equal_to: boolean_reset(cur_exp=0);
  15993.   unequal_to: boolean_reset(cur_exp<>0);
  15994.   end; {there are no other cases}
  15995.  cur_type:=boolean_type
  15996. @ When two unknown strings are in the same ring, we know that they are
  15997. equal. Otherwise, we don't know whether they are equal or not, so we
  15998. make no change.
  15999. @<Check if unknowns have been equated@>=
  16000. begin q:=value(cur_exp);
  16001. while (q<>cur_exp)and(q<>p) do q:=value(q);
  16002. if q=p then flush_cur_exp(0);
  16003. @ @<Reduce comparison of big nodes to comparison of scalars@>=
  16004. begin q:=value(p); r:=value(cur_exp);
  16005. rr:=r+big_node_size[cur_type]-2;
  16006. loop@+  begin add_or_subtract(q,r,minus);
  16007.   if type(r)<>known then goto done1;
  16008.   if value(r)<>0 then goto done1;
  16009.   if r=rr then goto done1;
  16010.   q:=q+2; r:=r+2;
  16011.   end;
  16012. done1:take_part(x_part+half(r-value(cur_exp)));
  16013. @ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|.
  16014. @<Additional cases of binary operators@>=
  16015. and_op,or_op: if (type(p)<>boolean_type)or(cur_type<>boolean_type) then
  16016.     bad_binary(p,c)
  16017.   else if value(p)=c+false_code-and_op then cur_exp:=value(p);
  16018. @ @<Additional cases of binary operators@>=
  16019. times: if (cur_type<pair_type)or(type(p)<pair_type) then bad_binary(p,times)
  16020.   else if (cur_type=known)or(type(p)=known) then
  16021.     @<Multiply when at least one operand is known@>
  16022.   else if (nice_pair(p,type(p))and(cur_type>pair_type))
  16023.       or(nice_pair(cur_exp,cur_type)and(type(p)>pair_type)) then
  16024.     begin hard_times(p); return;
  16025.     end
  16026.   else bad_binary(p,times);
  16027. @ @<Multiply when at least one operand is known@>=
  16028. begin if type(p)=known then
  16029.   begin v:=value(p); free_node(p,value_node_size);
  16030.   end
  16031. else  begin v:=cur_exp; unstash_cur_exp(p);
  16032.   end;
  16033. if cur_type=known then cur_exp:=take_scaled(cur_exp,v)
  16034. else if cur_type=pair_type then
  16035.   begin p:=value(cur_exp);
  16036.   dep_mult(x_part_loc(p),v,true);
  16037.   dep_mult(y_part_loc(p),v,true);
  16038.   end
  16039. else dep_mult(null,v,true);
  16040. return;
  16041. @ @<Declare binary action...@>=
  16042. procedure dep_mult(@!p:pointer;@!v:integer;@!v_is_scaled:boolean);
  16043. label exit;
  16044. var @!q:pointer; {the dependency list being multiplied by |v|}
  16045. @!s,@!t:small_number; {its type, before and after}
  16046. begin if p=null then q:=cur_exp
  16047. else if type(p)<>known then q:=p
  16048. else  begin if v_is_scaled then value(p):=take_scaled(value(p),v)
  16049.   else value(p):=take_fraction(value(p),v);
  16050.   return;
  16051.   end;
  16052. t:=type(q); q:=dep_list(q); s:=t;
  16053. if t=dependent then if v_is_scaled then
  16054.   if ab_vs_cd(max_coef(q),abs(v),coef_bound-1,unity)>=0 then t:=proto_dependent;
  16055. q:=p_times_v(q,v,s,t,v_is_scaled); dep_finish(q,p,t);
  16056. exit:end;
  16057. @ Here is a routine that is similar to |times|; but it is invoked only
  16058. internally, when |v| is a |fraction| whose magnitude is at most~1,
  16059. and when |cur_type>=pair_type|.
  16060. @p procedure frac_mult(@!n,@!d:scaled); {multiplies |cur_exp| by |n/d|}
  16061. var @!p:pointer; {a pair node}
  16062. @!old_exp:pointer; {a capsule to recycle}
  16063. @!v:fraction; {|n/d|}
  16064. begin if internal[tracing_commands]>two then
  16065.   @<Trace the fraction multiplication@>;
  16066. case cur_type of
  16067. transform_type,pair_type:old_exp:=tarnished(cur_exp);
  16068. independent:old_exp:=void;
  16069. othercases old_exp:=null
  16070. endcases;
  16071. if old_exp<>null then
  16072.   begin old_exp:=cur_exp; make_exp_copy(old_exp);
  16073.   end;
  16074. v:=make_fraction(n,d);
  16075. if cur_type=known then cur_exp:=take_fraction(cur_exp,v)
  16076. else if cur_type=pair_type then
  16077.   begin p:=value(cur_exp);
  16078.   dep_mult(x_part_loc(p),v,false);
  16079.   dep_mult(y_part_loc(p),v,false);
  16080.   end
  16081. else dep_mult(null,v,false);
  16082. if old_exp<>null then
  16083.   begin recycle_value(old_exp); free_node(old_exp,value_node_size);
  16084.   end
  16085. @ @<Trace the fraction multiplication@>=
  16086. begin begin_diagnostic; print_nl("{("); print_scaled(n); print_char("/");
  16087. print_scaled(d); print(")*("); print_exp(null,0); print(")}");
  16088. end_diagnostic(false);
  16089. @ The |hard_times| routine multiplies a nice pair by a dependency list.
  16090. @<Declare binary action procedures@>=
  16091. procedure hard_times(@!p:pointer);
  16092. var @!q:pointer; {a copy of the dependent variable |p|}
  16093. @!r:pointer; {the big node for the nice pair}
  16094. @!u,@!v:scaled; {the known values of the nice pair}
  16095. begin if type(p)=pair_type then
  16096.   begin q:=stash_cur_exp; unstash_cur_exp(p); p:=q;
  16097.   end; {now |cur_type=pair_type|}
  16098. r:=value(cur_exp); u:=value(x_part_loc(r)); v:=value(y_part_loc(r));
  16099. @<Move the dependent variable |p| into both parts of the pair node |r|@>;
  16100. dep_mult(x_part_loc(r),u,true); dep_mult(y_part_loc(r),v,true);
  16101. @ @<Move the dependent variable |p|...@>=
  16102. type(y_part_loc(r)):=type(p);
  16103. new_dep(y_part_loc(r),copy_dep_list(dep_list(p)));@/
  16104. type(x_part_loc(r)):=type(p);
  16105. mem[value_loc(x_part_loc(r))]:=mem[value_loc(p)];
  16106. link(prev_dep(p)):=x_part_loc(r);
  16107. free_node(p,value_node_size)
  16108. @ @<Additional cases of binary operators@>=
  16109. over: if (cur_type<>known)or(type(p)<pair_type) then bad_binary(p,over)
  16110.   else  begin v:=cur_exp; unstash_cur_exp(p);
  16111.     if v=0 then @<Squeal about division by zero@>
  16112.     else  begin if cur_type=known then cur_exp:=make_scaled(cur_exp,v)
  16113.       else if cur_type=pair_type then
  16114.         begin p:=value(cur_exp);
  16115.         dep_div(x_part_loc(p),v);
  16116.         dep_div(y_part_loc(p),v);
  16117.         end
  16118.       else dep_div(null,v);
  16119.       end;
  16120.     return;
  16121.     end;
  16122. @ @<Declare binary action...@>=
  16123. procedure dep_div(@!p:pointer;@!v:scaled);
  16124. label exit;
  16125. var @!q:pointer; {the dependency list being divided by |v|}
  16126. @!s,@!t:small_number; {its type, before and after}
  16127. begin if p=null then q:=cur_exp
  16128. else if type(p)<>known then q:=p
  16129. else  begin value(p):=make_scaled(value(p),v); return;
  16130.   end;
  16131. t:=type(q); q:=dep_list(q); s:=t;
  16132. if t=dependent then
  16133.   if ab_vs_cd(max_coef(q),unity,coef_bound-1,abs(v))>=0 then t:=proto_dependent;
  16134. q:=p_over_v(q,v,s,t); dep_finish(q,p,t);
  16135. exit:end;
  16136. @ @<Squeal about division by zero@>=
  16137. begin exp_err("Division by zero");
  16138. @.Division by zero@>
  16139. help2("You're trying to divide the quantity shown above the error")@/
  16140.   ("message by zero. I'm going to divide it by one instead.");
  16141. put_get_error;
  16142. @ @<Additional cases of binary operators@>=
  16143. pythag_add,pythag_sub: if (cur_type=known)and(type(p)=known) then
  16144.     if c=pythag_add then cur_exp:=pyth_add(value(p),cur_exp)
  16145.     else cur_exp:=pyth_sub(value(p),cur_exp)
  16146.   else bad_binary(p,c);
  16147. @ The next few sections of the program deal with affine transformations
  16148. of coordinate data.
  16149. @<Additional cases of binary operators@>=
  16150. rotated_by,slanted_by,scaled_by,shifted_by,transformed_by,
  16151.  x_scaled,y_scaled,z_scaled: @t@>@;@/
  16152.   if (type(p)=path_type)or(type(p)=future_pen)or(type(p)=pen_type) then
  16153.     begin path_trans(p,c); return;
  16154.     end
  16155.   else if (type(p)=pair_type)or(type(p)=transform_type) then big_trans(p,c)
  16156.   else if type(p)=picture_type then
  16157.     begin edges_trans(p,c); return;
  16158.     end
  16159.   else bad_binary(p,c);
  16160. @ Let |c| be one of the eight transform operators. The procedure call
  16161. |set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to
  16162. |c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't
  16163. change at all if |c=transformed_by|.)
  16164. Then, if all components of the resulting transform are |known|, they are
  16165. moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|;
  16166. and |cur_exp| is changed to the known value zero.
  16167. @<Declare binary action...@>=
  16168. procedure set_up_trans(@!c:quarterword);
  16169. label done,exit;
  16170. var @!p,@!q,@!r:pointer; {list manipulation registers}
  16171. begin if (c<>transformed_by)or(cur_type<>transform_type) then
  16172.   @<Put the current transform into |cur_exp|@>;
  16173. @<If the current transform is entirely known, stash it in global variables;
  16174.   otherwise |return|@>;
  16175. exit:end;
  16176. @ @<Glob...@>=
  16177. @!txx,@!txy,@!tyx,@!tyy,@!tx,@!ty:scaled; {current transform coefficients}
  16178. @ @<Put the current transform...@>=
  16179. begin p:=stash_cur_exp; cur_exp:=id_transform; cur_type:=transform_type;
  16180. q:=value(cur_exp);
  16181. case c of
  16182. @<For each of the eight cases, change the relevant fields of |cur_exp|
  16183.   and |goto done|;
  16184.   but do nothing if capsule |p| doesn't have the appropriate type@>@;
  16185. end; {there are no other cases}
  16186. disp_err(p,"Improper transformation argument");
  16187. @.Improper transformation argument@>
  16188. help3("The expression shown above has the wrong type,")@/
  16189.   ("so I can't transform anything using it.")@/
  16190.   ("Proceed, and I'll omit the transformation.");
  16191. put_get_error;
  16192. done: recycle_value(p); free_node(p,value_node_size);
  16193. @ @<If the current transform is entirely known, ...@>=
  16194. q:=value(cur_exp); r:=q+transform_node_size;
  16195. repeat r:=r-2;
  16196. if type(r)<>known then return;
  16197. until r=q;
  16198. txx:=value(xx_part_loc(q));
  16199. txy:=value(xy_part_loc(q));
  16200. tyx:=value(yx_part_loc(q));
  16201. tyy:=value(yy_part_loc(q));
  16202. tx:=value(x_part_loc(q));
  16203. ty:=value(y_part_loc(q));
  16204. flush_cur_exp(0)
  16205. @ @<For each of the eight cases...@>=
  16206. rotated_by:if type(p)=known then
  16207.   @<Install sines and cosines, then |goto done|@>;
  16208. slanted_by:if type(p)>pair_type then
  16209.   begin install(xy_part_loc(q),p); goto done;
  16210.   end;
  16211. scaled_by:if type(p)>pair_type then
  16212.   begin install(xx_part_loc(q),p); install(yy_part_loc(q),p); goto done;
  16213.   end;
  16214. shifted_by:if type(p)=pair_type then
  16215.   begin r:=value(p); install(x_part_loc(q),x_part_loc(r));
  16216.   install(y_part_loc(q),y_part_loc(r)); goto done;
  16217.   end;
  16218. x_scaled:if type(p)>pair_type then
  16219.   begin install(xx_part_loc(q),p); goto done;
  16220.   end;
  16221. y_scaled:if type(p)>pair_type then
  16222.   begin install(yy_part_loc(q),p); goto done;
  16223.   end;
  16224. z_scaled:if type(p)=pair_type then
  16225.   @<Install a complex multiplier, then |goto done|@>;
  16226. transformed_by:do_nothing;
  16227. @ @<Install sines and cosines, then |goto done|@>=
  16228. begin n_sin_cos((value(p) mod three_sixty_units)*16);
  16229. value(xx_part_loc(q)):=round_fraction(n_cos);
  16230. value(yx_part_loc(q)):=round_fraction(n_sin);
  16231. value(xy_part_loc(q)):=-value(yx_part_loc(q));
  16232. value(yy_part_loc(q)):=value(xx_part_loc(q));
  16233. goto done;
  16234. @ @<Install a complex multiplier, then |goto done|@>=
  16235. begin r:=value(p);
  16236. install(xx_part_loc(q),x_part_loc(r));
  16237. install(yy_part_loc(q),x_part_loc(r));
  16238. install(yx_part_loc(q),y_part_loc(r));
  16239. if type(y_part_loc(r))=known then negate(value(y_part_loc(r)))
  16240. else negate_dep_list(dep_list(y_part_loc(r)));
  16241. install(xy_part_loc(q),y_part_loc(r));
  16242. goto done;
  16243. @ Procedure |set_up_known_trans| is like |set_up_trans|, but it
  16244. insists that the transformation be entirely known.
  16245. @<Declare binary action...@>=
  16246. procedure set_up_known_trans(@!c:quarterword);
  16247. begin set_up_trans(c);
  16248. if cur_type<>known then
  16249.   begin exp_err("Transform components aren't all known");
  16250. @.Transform components...@>
  16251.   help3("I'm unable to apply a partially specified transformation")@/
  16252.     ("except to a fully known pair or transform.")@/
  16253.     ("Proceed, and I'll omit the transformation.");
  16254.   put_get_flush_error(0);
  16255.   txx:=unity; txy:=0; tyx:=0; tyy:=unity; tx:=0; ty:=0;
  16256.   end;
  16257. @ Here's a procedure that applies the transform |txx..ty| to a pair of
  16258. coordinates in locations |p| and~|q|.
  16259. @<Declare binary action...@>=
  16260. procedure trans(@!p,@!q:pointer);
  16261. var @!v:scaled; {the new |x| value}
  16262. begin v:=take_scaled(mem[p].sc,txx)+take_scaled(mem[q].sc,txy)+tx;
  16263. mem[q].sc:=take_scaled(mem[p].sc,tyx)+take_scaled(mem[q].sc,tyy)+ty;
  16264. mem[p].sc:=v;
  16265. @ The simplest transformation procedure applies a transform to all
  16266. coordinates of a path. The |null_pen| remains unchanged if it isn't
  16267. being shifted.
  16268. @<Declare binary action...@>=
  16269. procedure path_trans(@!p:pointer;@!c:quarterword);
  16270. label exit;
  16271. var @!q:pointer; {list traverser}
  16272. begin set_up_known_trans(c); unstash_cur_exp(p);
  16273. if cur_type=pen_type then
  16274.   begin if max_offset(cur_exp)=0 then if tx=0 then if ty=0 then return;
  16275.   flush_cur_exp(make_path(cur_exp)); cur_type:=future_pen;
  16276.   end;
  16277. q:=cur_exp;
  16278. repeat if left_type(q)<>endpoint then
  16279.   trans(q+3,q+4); {that's |left_x| and |left_y|}
  16280. trans(q+1,q+2); {that's |x_coord| and |y_coord|}
  16281. if right_type(q)<>endpoint then
  16282.   trans(q+5,q+6); {that's |right_x| and |right_y|}
  16283. q:=link(q);
  16284. until q=cur_exp;
  16285. exit:end;
  16286. @ The next simplest transformation procedure applies to edges.
  16287. It is simple primarily because \MF\ doesn't allow very general
  16288. transformations to be made, and because the tricky subroutines
  16289. for edge transformation have already been written.
  16290. @<Declare binary action...@>=
  16291. procedure edges_trans(@!p:pointer;@!c:quarterword);
  16292. label exit;
  16293. begin set_up_known_trans(c); unstash_cur_exp(p); cur_edges:=cur_exp;
  16294. if empty_edges(cur_edges) then return; {the empty set is easy to transform}
  16295. if txx=0 then if tyy=0 then
  16296.  if txy mod unity=0 then if tyx mod unity=0 then
  16297.   begin xy_swap_edges; txx:=txy; tyy:=tyx; txy:=0; tyx:=0;
  16298.   if empty_edges(cur_edges) then return;
  16299.   end;
  16300. if txy=0 then if tyx=0 then
  16301.  if txx mod unity=0 then if tyy mod unity=0 then
  16302.   @<Scale the edges, shift them, and |return|@>;
  16303. print_err("That transformation is too hard");
  16304. @.That transformation...@>
  16305. help3("I can apply complicated transformations to paths,")@/
  16306.   ("but I can only do integer operations on pictures.")@/
  16307.   ("Proceed, and I'll omit the transformation.");
  16308. put_get_error;
  16309. exit:end;
  16310. @ @<Scale the edges, shift them, and |return|@>=
  16311. begin if (txx=0)or(tyy=0) then
  16312.   begin toss_edges(cur_edges);
  16313.   cur_exp:=get_node(edge_header_size); init_edges(cur_exp);
  16314.   end
  16315. else  begin if txx<0 then
  16316.     begin x_reflect_edges; txx:=-txx;
  16317.     end;
  16318.   if tyy<0 then
  16319.     begin y_reflect_edges; tyy:=-tyy;
  16320.     end;
  16321.   if txx<>unity then x_scale_edges(txx div unity);
  16322.   if tyy<>unity then y_scale_edges(tyy div unity);
  16323.   @<Shift the edges by |(tx,ty)|, rounded@>;
  16324.   end;
  16325. return;
  16326. @ @<Shift the edges...@>=
  16327. tx:=round_unscaled(tx); ty:=round_unscaled(ty);
  16328. if (m_min(cur_edges)+tx<=0)or(m_max(cur_edges)+tx>=8192)or@|
  16329.  (n_min(cur_edges)+ty<=0)or(n_max(cur_edges)+ty>=8191)or@|
  16330.  (abs(tx)>=4096)or(abs(ty)>=4096) then
  16331.   begin print_err("Too far to shift");
  16332. @.Too far to shift@>
  16333.   help3("I can't shift the picture as requested---it would")@/
  16334.     ("make some coordinates too large or too small.")@/
  16335.     ("Proceed, and I'll omit the transformation.");
  16336.   put_get_error;
  16337.   end
  16338. else  begin if tx<>0 then
  16339.     begin if not valid_range(m_offset(cur_edges)-tx) then fix_offset;
  16340.     m_min(cur_edges):=m_min(cur_edges)+tx;
  16341.     m_max(cur_edges):=m_max(cur_edges)+tx;
  16342.     m_offset(cur_edges):=m_offset(cur_edges)-tx;
  16343.     last_window_time(cur_edges):=0;
  16344.     end;
  16345.   if ty<>0 then
  16346.     begin n_min(cur_edges):=n_min(cur_edges)+ty;
  16347.     n_max(cur_edges):=n_max(cur_edges)+ty;
  16348.     n_pos(cur_edges):=n_pos(cur_edges)+ty;
  16349.     last_window_time(cur_edges):=0;
  16350.     end;
  16351.   end
  16352. @ The hard cases of transformation occur when big nodes are involved,
  16353. and when some of their components are unknown.
  16354. @<Declare binary action...@>=
  16355. @t\4@>@<Declare subroutines needed by |big_trans|@>@;
  16356. procedure big_trans(@!p:pointer;@!c:quarterword);
  16357. label exit;
  16358. var @!q,@!r,@!pp,@!qq:pointer; {list manipulation registers}
  16359. @!s:small_number; {size of a big node}
  16360. begin s:=big_node_size[type(p)]; q:=value(p); r:=q+s;
  16361. repeat r:=r-2;
  16362. if type(r)<>known then @<Transform an unknown big node and |return|@>;
  16363. until r=q;
  16364. @<Transform a known big node@>;
  16365. exit:end; {node |p| will now be recycled by |do_binary|}
  16366. @ @<Transform an unknown big node and |return|@>=
  16367. begin set_up_known_trans(c); make_exp_copy(p); r:=value(cur_exp);
  16368. if cur_type=transform_type then
  16369.   begin bilin1(yy_part_loc(r),tyy,xy_part_loc(q),tyx,0);
  16370.   bilin1(yx_part_loc(r),tyy,xx_part_loc(q),tyx,0);
  16371.   bilin1(xy_part_loc(r),txx,yy_part_loc(q),txy,0);
  16372.   bilin1(xx_part_loc(r),txx,yx_part_loc(q),txy,0);
  16373.   end;
  16374. bilin1(y_part_loc(r),tyy,x_part_loc(q),tyx,ty);
  16375. bilin1(x_part_loc(r),txx,y_part_loc(q),txy,tx);
  16376. return;
  16377. @ Let |p| point to a two-word value field inside a big node of |cur_exp|,
  16378. and let |q| point to a another value field. The |bilin1| procedure
  16379. replaces |p| by $p\cdot t+q\cdot u+\delta$.
  16380. @<Declare subroutines needed by |big_trans|@>=
  16381. procedure bilin1(@!p:pointer;@!t:scaled;@!q:pointer;@!u,@!delta:scaled);
  16382. var @!r:pointer; {list traverser}
  16383. begin if t<>unity then dep_mult(p,t,true);
  16384. if u<>0 then
  16385.   if type(q)=known then delta:=delta+take_scaled(value(q),u)
  16386.   else  begin @<Ensure that |type(p)=proto_dependent|@>;
  16387.     dep_list(p):=p_plus_fq(dep_list(p),u,dep_list(q),proto_dependent,type(q));
  16388.     end;
  16389. if type(p)=known then value(p):=value(p)+delta
  16390. else  begin r:=dep_list(p);
  16391.   while info(r)<>null do r:=link(r);
  16392.   delta:=value(r)+delta;
  16393.   if r<>dep_list(p) then value(r):=delta
  16394.   else  begin recycle_value(p); type(p):=known; value(p):=delta;
  16395.     end;
  16396.   end;
  16397. if fix_needed then fix_dependencies;
  16398. @ @<Ensure that |type(p)=proto_dependent|@>=
  16399. if type(p)<>proto_dependent then
  16400.   begin if type(p)=known then new_dep(p,const_dependency(value(p)))
  16401.   else dep_list(p):=p_times_v(dep_list(p),unity,dependent,proto_dependent,true);
  16402.   type(p):=proto_dependent;
  16403.   end
  16404. @ @<Transform a known big node@>=
  16405. set_up_trans(c);
  16406. if cur_type=known then @<Transform known by known@>
  16407. else  begin pp:=stash_cur_exp; qq:=value(pp);
  16408.   make_exp_copy(p); r:=value(cur_exp);
  16409.   if cur_type=transform_type then
  16410.     begin bilin2(yy_part_loc(r),yy_part_loc(qq),
  16411.       value(xy_part_loc(q)),yx_part_loc(qq),null);
  16412.     bilin2(yx_part_loc(r),yy_part_loc(qq),
  16413.       value(xx_part_loc(q)),yx_part_loc(qq),null);
  16414.     bilin2(xy_part_loc(r),xx_part_loc(qq),
  16415.       value(yy_part_loc(q)),xy_part_loc(qq),null);
  16416.     bilin2(xx_part_loc(r),xx_part_loc(qq),
  16417.       value(yx_part_loc(q)),xy_part_loc(qq),null);
  16418.     end;
  16419.   bilin2(y_part_loc(r),yy_part_loc(qq),
  16420.     value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq));
  16421.   bilin2(x_part_loc(r),xx_part_loc(qq),
  16422.     value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq));
  16423.   recycle_value(pp); free_node(pp,value_node_size);
  16424.   end;
  16425. @ Let |p| be a |proto_dependent| value whose dependency list ends
  16426. at |dep_final|. The following procedure adds |v| times another
  16427. numeric quantity to~|p|.
  16428. @<Declare subroutines needed by |big_trans|@>=
  16429. procedure add_mult_dep(@!p:pointer;@!v:scaled;@!r:pointer);
  16430. begin if type(r)=known then
  16431.   value(dep_final):=value(dep_final)+take_scaled(value(r),v)
  16432. else  begin dep_list(p):=
  16433.    p_plus_fq(dep_list(p),v,dep_list(r),proto_dependent,type(r));
  16434.   if fix_needed then fix_dependencies;
  16435.   end;
  16436. @ The |bilin2| procedure is something like |bilin1|, but with known
  16437. and unknown quantities reversed. Parameter |p| points to a value field
  16438. within the big node for |cur_exp|; and |type(p)=known|. Parameters
  16439. |t| and~|u| point to value fields elsewhere; so does parameter~|q|,
  16440. unless it is |null| (which stands for zero). Location~|p| will be
  16441. replaced by $p\cdot t+v\cdot u+q$.
  16442. @<Declare subroutines needed by |big_trans|@>=
  16443. procedure bilin2(@!p,@!t:pointer;@!v:scaled;@!u,@!q:pointer);
  16444. var @!vv:scaled; {temporary storage for |value(p)|}
  16445. begin vv:=value(p); type(p):=proto_dependent;
  16446. new_dep(p,const_dependency(0)); {this sets |dep_final|}
  16447. if vv<>0 then add_mult_dep(p,vv,t); {|dep_final| doesn't change}
  16448. if v<>0 then add_mult_dep(p,v,u);
  16449. if q<>null then add_mult_dep(p,unity,q);
  16450. if dep_list(p)=dep_final then
  16451.   begin vv:=value(dep_final); recycle_value(p);
  16452.   type(p):=known; value(p):=vv;
  16453.   end;
  16454. @ @<Transform known by known@>=
  16455. begin make_exp_copy(p); r:=value(cur_exp);
  16456. if cur_type=transform_type then
  16457.   begin bilin3(yy_part_loc(r),tyy,value(xy_part_loc(q)),tyx,0);
  16458.   bilin3(yx_part_loc(r),tyy,value(xx_part_loc(q)),tyx,0);
  16459.   bilin3(xy_part_loc(r),txx,value(yy_part_loc(q)),txy,0);
  16460.   bilin3(xx_part_loc(r),txx,value(yx_part_loc(q)),txy,0);
  16461.   end;
  16462. bilin3(y_part_loc(r),tyy,value(x_part_loc(q)),tyx,ty);
  16463. bilin3(x_part_loc(r),txx,value(y_part_loc(q)),txy,tx);
  16464. @ Finally, in |bilin3| everything is |known|.
  16465. @<Declare subroutines needed by |big_trans|@>=
  16466. procedure bilin3(@!p:pointer;@!t,@!v,@!u,@!delta:scaled);
  16467. begin if t<>unity then delta:=delta+take_scaled(value(p),t)
  16468. else delta:=delta+value(p);
  16469. if u<>0 then value(p):=delta+take_scaled(v,u)
  16470. else value(p):=delta;
  16471. @ @<Additional cases of binary operators@>=
  16472. concatenate: if (cur_type=string_type)and(type(p)=string_type) then cat(p)
  16473.   else bad_binary(p,concatenate);
  16474. substring_of: if nice_pair(p,type(p))and(cur_type=string_type) then
  16475.     chop_string(value(p))
  16476.   else bad_binary(p,substring_of);
  16477. subpath_of: begin if cur_type=pair_type then pair_to_path;
  16478.   if nice_pair(p,type(p))and(cur_type=path_type) then
  16479.     chop_path(value(p))
  16480.   else bad_binary(p,subpath_of);
  16481.   end;
  16482. @ @<Declare binary action...@>=
  16483. procedure cat(@!p:pointer);
  16484. var @!a,@!b:str_number; {the strings being concatenated}
  16485. @!k:pool_pointer; {index into |str_pool|}
  16486. begin a:=value(p); b:=cur_exp; str_room(length(a)+length(b));
  16487. for k:=str_start[a] to str_start[a+1]-1 do append_char(so(str_pool[k]));
  16488. for k:=str_start[b] to str_start[b+1]-1 do append_char(so(str_pool[k]));
  16489. cur_exp:=make_string; delete_str_ref(b);
  16490. @ @<Declare binary action...@>=
  16491. procedure chop_string(@!p:pointer);
  16492. var @!a,@!b:integer; {start and stop points}
  16493. @!l:integer; {length of the original string}
  16494. @!k:integer; {runs from |a| to |b|}
  16495. @!s:str_number; {the original string}
  16496. @!reversed:boolean; {was |a>b|?}
  16497. begin a:=round_unscaled(value(x_part_loc(p)));
  16498. b:=round_unscaled(value(y_part_loc(p)));
  16499. if a<=b then reversed:=false
  16500. else  begin reversed:=true; k:=a; a:=b; b:=k;
  16501.   end;
  16502. s:=cur_exp; l:=length(s);
  16503. if a<0 then
  16504.   begin a:=0;
  16505.   if b<0 then b:=0;
  16506.   end;
  16507. if b>l then
  16508.   begin b:=l;
  16509.   if a>l then a:=l;
  16510.   end;
  16511. str_room(b-a);
  16512. if reversed then
  16513.   for k:=str_start[s]+b-1 downto str_start[s]+a do append_char(so(str_pool[k]))
  16514. else for k:=str_start[s]+a to str_start[s]+b-1 do append_char(so(str_pool[k]));
  16515. cur_exp:=make_string; delete_str_ref(s);
  16516. @ @<Declare binary action...@>=
  16517. procedure chop_path(@!p:pointer);
  16518. var @!q:pointer; {a knot in the original path}
  16519. @!pp,@!qq,@!rr,@!ss:pointer; {link variables for copies of path nodes}
  16520. @!a,@!b,@!k,@!l:scaled; {indices for chopping}
  16521. @!reversed:boolean; {was |a>b|?}
  16522. begin l:=path_length; a:=value(x_part_loc(p)); b:=value(y_part_loc(p));
  16523. if a<=b then reversed:=false
  16524. else  begin reversed:=true; k:=a; a:=b; b:=k;
  16525.   end;
  16526. @<Dispense with the cases |a<0| and/or |b>l|@>;
  16527. q:=cur_exp;
  16528. while a>=unity do
  16529.   begin q:=link(q); a:=a-unity; b:=b-unity;
  16530.   end;
  16531. if b=a then @<Construct a path from |pp| to |qq| of length zero@>
  16532. else @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>;
  16533. left_type(pp):=endpoint; right_type(qq):=endpoint; link(qq):=pp;
  16534. toss_knot_list(cur_exp);
  16535. if reversed then
  16536.   begin cur_exp:=link(htap_ypoc(pp)); toss_knot_list(pp);
  16537.   end
  16538. else cur_exp:=pp;
  16539. @ @<Dispense with the cases |a<0| and/or |b>l|@>=
  16540. if a<0 then
  16541.   if left_type(cur_exp)=endpoint then
  16542.     begin a:=0; if b<0 then b:=0;
  16543.     end
  16544.   else  repeat a:=a+l; b:=b+l;
  16545.     until a>=0; {a cycle always has length |l>0|}
  16546. if b>l then if left_type(cur_exp)=endpoint then
  16547.     begin b:=l; if a>l then a:=l;
  16548.     end
  16549.   else while a>=l do
  16550.     begin a:=a-l; b:=b-l;
  16551.     end
  16552. @ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>=
  16553. begin pp:=copy_knot(q); qq:=pp;
  16554. repeat q:=link(q); rr:=qq; qq:=copy_knot(q); link(rr):=qq; b:=b-unity;
  16555. until b<=0;
  16556. if a>0 then
  16557.   begin ss:=pp; pp:=link(pp);
  16558.   split_cubic(ss,a*@'10000,x_coord(pp),y_coord(pp)); pp:=link(ss);
  16559.   free_node(ss,knot_node_size);
  16560.   if rr=ss then
  16561.     begin b:=make_scaled(b,unity-a); rr:=pp;
  16562.     end;
  16563.   end;
  16564. if b<0 then
  16565.   begin split_cubic(rr,(b+unity)*@'10000,x_coord(qq),y_coord(qq));
  16566.   free_node(qq,knot_node_size);
  16567.   qq:=link(rr);
  16568.   end;
  16569. @ @<Construct a path from |pp| to |qq| of length zero@>=
  16570. begin if a>0 then
  16571.   begin qq:=link(q);
  16572.   split_cubic(q,a*@'10000,x_coord(qq),y_coord(qq)); q:=link(q);
  16573.   end;
  16574. pp:=copy_knot(q); qq:=pp;
  16575. @ The |pair_value| routine changes the current expression to a
  16576. given ordered pair of values.
  16577. @<Declare binary action...@>=
  16578. procedure pair_value(@!x,@!y:scaled);
  16579. var @!p:pointer; {a pair node}
  16580. begin p:=get_node(value_node_size); flush_cur_exp(p); cur_type:=pair_type;
  16581. type(p):=pair_type; name_type(p):=capsule; init_big_node(p);
  16582. p:=value(p);@/
  16583. type(x_part_loc(p)):=known; value(x_part_loc(p)):=x;@/
  16584. type(y_part_loc(p)):=known; value(y_part_loc(p)):=y;@/
  16585. @ @<Additional cases of binary operators@>=
  16586. point_of,precontrol_of,postcontrol_of: begin if cur_type=pair_type then
  16587.      pair_to_path;
  16588.   if (cur_type=path_type)and(type(p)=known) then
  16589.     find_point(value(p),c)
  16590.   else bad_binary(p,c);
  16591.   end;
  16592. pen_offset_of: begin if cur_type=future_pen then materialize_pen;
  16593.   if (cur_type=pen_type)and nice_pair(p,type(p)) then
  16594.     set_up_offset(value(p))
  16595.   else bad_binary(p,pen_offset_of);
  16596.   end;
  16597. direction_time_of: begin if cur_type=pair_type then pair_to_path;
  16598.   if (cur_type=path_type)and nice_pair(p,type(p)) then
  16599.     set_up_direction_time(value(p))
  16600.   else bad_binary(p,direction_time_of);
  16601.   end;
  16602. @ @<Declare binary action...@>=
  16603. procedure set_up_offset(@!p:pointer);
  16604. begin find_offset(value(x_part_loc(p)),value(y_part_loc(p)),cur_exp);
  16605. pair_value(cur_x,cur_y);
  16606. procedure set_up_direction_time(@!p:pointer);
  16607. begin flush_cur_exp(find_direction_time(value(x_part_loc(p)),
  16608.   value(y_part_loc(p)),cur_exp));
  16609. @ @<Declare binary action...@>=
  16610. procedure find_point(@!v:scaled;@!c:quarterword);
  16611. var @!p:pointer; {the path}
  16612. @!n:scaled; {its length}
  16613. @!q:pointer; {successor of |p|}
  16614. begin p:=cur_exp;@/
  16615. if left_type(p)=endpoint then n:=-unity@+else n:=0;
  16616. repeat p:=link(p); n:=n+unity;
  16617. until p=cur_exp;
  16618. if n=0 then v:=0
  16619. else if v<0 then
  16620.   if left_type(p)=endpoint then v:=0
  16621.   else v:=n-1-((-v-1) mod n)
  16622. else if v>n then
  16623.   if left_type(p)=endpoint then v:=n
  16624.   else v:=v mod n;
  16625. p:=cur_exp;
  16626. while v>=unity do
  16627.   begin p:=link(p); v:=v-unity;
  16628.   end;
  16629. if v<>0 then @<Insert a fractional node by splitting the cubic@>;
  16630. @<Set the current expression to the desired path coordinates@>;
  16631. @ @<Insert a fractional node...@>=
  16632. begin q:=link(p); split_cubic(p,v*@'10000,x_coord(q),y_coord(q)); p:=link(p);
  16633. @ @<Set the current expression to the desired path coordinates...@>=
  16634. case c of
  16635. point_of: pair_value(x_coord(p),y_coord(p));
  16636. precontrol_of: if left_type(p)=endpoint then pair_value(x_coord(p),y_coord(p))
  16637.   else pair_value(left_x(p),left_y(p));
  16638. postcontrol_of: if right_type(p)=endpoint then pair_value(x_coord(p),y_coord(p))
  16639.   else pair_value(right_x(p),right_y(p));
  16640. end {there are no other cases}
  16641. @ @<Additional cases of bin...@>=
  16642. intersect: begin if type(p)=pair_type then
  16643.     begin q:=stash_cur_exp; unstash_cur_exp(p);
  16644.     pair_to_path; p:=stash_cur_exp; unstash_cur_exp(q);
  16645.     end;
  16646.   if cur_type=pair_type then pair_to_path;
  16647.   if (cur_type=path_type)and(type(p)=path_type) then
  16648.     begin path_intersection(value(p),cur_exp);
  16649.     pair_value(cur_t,cur_tt);
  16650.     end
  16651.   else bad_binary(p,intersect);
  16652.   end;
  16653. @* \[43] Statements and commands.
  16654. The chief executive of \MF\ is the |do_statement| routine, which
  16655. contains the master switch that causes all the various pieces of \MF\
  16656. to do their things, in the right order.
  16657. In a sense, this is the grand climax of the program: It applies all the
  16658. tools that we have worked so hard to construct. In another sense, this is
  16659. the messiest part of the program: It necessarily refers to other pieces
  16660. of code all over the place, so that a person can't fully understand what is
  16661. going on without paging back and forth to be reminded of conventions that
  16662. are defined elsewhere. We are now at the hub of the web.
  16663. The structure of |do_statement| itself is quite simple.  The first token
  16664. of the statement is fetched using |get_x_next|.  If it can be the first
  16665. token of an expression, we look for an equation, an assignment, or a
  16666. title. Otherwise we use a \&{case} construction to branch at high speed to
  16667. the appropriate routine for various and sundry other types of commands,
  16668. each of which has an ``action procedure'' that does the necessary work.
  16669. The program uses the fact that
  16670. $$\hbox{|min_primary_command=max_statement_command=type_name|}$$
  16671. to interpret a statement that starts with, e.g., `\&{string}',
  16672. as a type declaration rather than a boolean expression.
  16673. @p @t\4@>@<Declare generic font output procedures@>@;
  16674. @t\4@>@<Declare action procedures for use by |do_statement|@>@;
  16675. procedure do_statement; {governs \MF's activities}
  16676. begin cur_type:=vacuous; get_x_next;
  16677. if cur_cmd>max_primary_command then @<Worry about bad statement@>
  16678. else if cur_cmd>max_statement_command then
  16679.   @<Do an equation, assignment, title, or
  16680.    `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@>
  16681. else @<Do a statement that doesn't begin with an expression@>;
  16682. if cur_cmd<semicolon then
  16683.   @<Flush unparsable junk that was found after the statement@>;
  16684. error_count:=0;
  16685. @ The only command codes |>max_primary_command| that can be present
  16686. at the beginning of a statement are |semicolon| and higher; these
  16687. occur when the statement is null.
  16688. @<Worry about bad statement@>=
  16689. begin if cur_cmd<semicolon then
  16690.   begin print_err("A statement can't begin with `");
  16691. @.A statement can't begin with x@>
  16692.   print_cmd_mod(cur_cmd,cur_mod); print_char("'");
  16693.   help5("I was looking for the beginning of a new statement.")@/
  16694.     ("If you just proceed without changing anything, I'll ignore")@/
  16695.     ("everything up to the next `;'. Please insert a semicolon")@/
  16696.     ("now in front of anything that you don't want me to delete.")@/
  16697.     ("(See Chapter 27 of The METAFONTbook for an example.)");@/
  16698. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  16699.   back_error; get_x_next;
  16700.   end;
  16701. @ The help message printed here says that everything is flushed up to
  16702. a semicolon, but actually the commands |end_group| and |stop| will
  16703. also terminate a statement.
  16704. @<Flush unparsable junk that was found after the statement@>=
  16705. begin print_err("Extra tokens will be flushed");
  16706. @.Extra tokens will be flushed@>
  16707. help6("I've just read as much of that statement as I could fathom,")@/
  16708. ("so a semicolon should have been next. It's very puzzling...")@/
  16709. ("but I'll try to get myself back together, by ignoring")@/
  16710. ("everything up to the next `;'. Please insert a semicolon")@/
  16711. ("now in front of anything that you don't want me to delete.")@/
  16712. ("(See Chapter 27 of The METAFONTbook for an example.)");@/
  16713. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  16714. back_error; scanner_status:=flushing;
  16715. repeat get_next;
  16716. @<Decrease the string reference count...@>;
  16717. until end_of_statement; {|cur_cmd=semicolon|, |end_group|, or |stop|}
  16718. scanner_status:=normal;
  16719. @ If |do_statement| ends with |cur_cmd=end_group|, we should have
  16720. |cur_type=vacuous| unless the statement was simply an expression;
  16721. in the latter case, |cur_type| and |cur_exp| should represent that
  16722. expression.
  16723. @<Do a statement that doesn't...@>=
  16724. begin if internal[tracing_commands]>0 then show_cur_cmd_mod;
  16725. case cur_cmd of
  16726. type_name:do_type_declaration;
  16727. macro_def:if cur_mod>var_def then make_op_def
  16728.   else if cur_mod>end_def then scan_def;
  16729. @t\4@>@<Cases of |do_statement| that invoke particular commands@>@;
  16730. end; {there are no other cases}
  16731. cur_type:=vacuous;
  16732. @ The most important statements begin with expressions.
  16733. @<Do an equation, assignment, title, or...@>=
  16734. begin var_flag:=assignment; scan_expression;
  16735. if cur_cmd<end_group then
  16736.   begin if cur_cmd=equals then do_equation
  16737.   else if cur_cmd=assignment then do_assignment
  16738.   else if cur_type=string_type then @<Do a title@>
  16739.   else if cur_type<>vacuous then
  16740.     begin exp_err("Isolated expression");
  16741. @.Isolated expression@>
  16742.     help3("I couldn't find an `=' or `:=' after the")@/
  16743.       ("expression that is shown above this error message,")@/
  16744.       ("so I guess I'll just ignore it and carry on.");
  16745.     put_get_error;
  16746.     end;
  16747.   flush_cur_exp(0); cur_type:=vacuous;
  16748.   end;
  16749. @ @<Do a title@>=
  16750. begin if internal[tracing_titles]>0 then
  16751.   begin print_nl(""); slow_print(cur_exp); update_terminal;
  16752.   end;
  16753. if internal[proofing]>0 then
  16754.   @<Send the current expression as a title to the output file@>;
  16755. @ Equations and assignments are performed by the pair of mutually recursive
  16756. @^recursion@>
  16757. routines |do_equation| and |do_assignment|. These routines are called when
  16758. |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand
  16759. side is in |cur_type| and |cur_exp|, while the right-hand side is yet
  16760. to be scanned. After the routines are finished, |cur_type| and |cur_exp|
  16761. will be equal to the right-hand side (which will normally be equal
  16762. to the left-hand side).
  16763. @<Declare action procedures for use by |do_statement|@>=
  16764. @t\4@>@<Declare the procedure called |try_eq|@>@;
  16765. @t\4@>@<Declare the procedure called |make_eq|@>@;
  16766. procedure@?do_assignment; forward;@t\2@>@/
  16767. procedure do_equation;
  16768. var @!lhs:pointer; {capsule for the left-hand side}
  16769. @!p:pointer; {temporary register}
  16770. begin lhs:=stash_cur_exp; get_x_next; var_flag:=assignment; scan_expression;
  16771. if cur_cmd=equals then do_equation
  16772. else if cur_cmd=assignment then do_assignment;
  16773. if internal[tracing_commands]>two then @<Trace the current equation@>;
  16774. if cur_type=unknown_path then if type(lhs)=pair_type then
  16775.   begin p:=stash_cur_exp; unstash_cur_exp(lhs); lhs:=p;
  16776.   end; {in this case |make_eq| will change the pair to a path}
  16777. make_eq(lhs); {equate |lhs| to |(cur_type,cur_exp)|}
  16778. @ And |do_assignment| is similar to |do_expression|:
  16779. @<Declare action procedures for use by |do_statement|@>=
  16780. procedure do_assignment;
  16781. var @!lhs:pointer; {token list for the left-hand side}
  16782. @!p:pointer; {where the left-hand value is stored}
  16783. @!q:pointer; {temporary capsule for the right-hand value}
  16784. begin if cur_type<>token_list then
  16785.   begin exp_err("Improper `:=' will be changed to `='");
  16786. @.Improper `:='@>
  16787.   help2("I didn't find a variable name at the left of the `:=',")@/
  16788.     ("so I'm going to pretend that you said `=' instead.");@/
  16789.   error; do_equation;
  16790.   end
  16791. else  begin lhs:=cur_exp; cur_type:=vacuous;@/
  16792.   get_x_next; var_flag:=assignment; scan_expression;
  16793.   if cur_cmd=equals then do_equation
  16794.   else if cur_cmd=assignment then do_assignment;
  16795.   if internal[tracing_commands]>two then @<Trace the current assignment@>;
  16796.   if info(lhs)>hash_end then
  16797.     @<Assign the current expression to an internal variable@>
  16798.   else @<Assign the current expression to the variable |lhs|@>;
  16799.   flush_node_list(lhs);
  16800.   end;
  16801. @ @<Trace the current equation@>=
  16802. begin begin_diagnostic; print_nl("{("); print_exp(lhs,0);
  16803. print(")=("); print_exp(null,0); print(")}"); end_diagnostic(false);
  16804. @ @<Trace the current assignment@>=
  16805. begin begin_diagnostic; print_nl("{");
  16806. if info(lhs)>hash_end then slow_print(int_name[info(lhs)-(hash_end)])
  16807. else show_token_list(lhs,null,1000,0);
  16808. print(":="); print_exp(null,0); print_char("}"); end_diagnostic(false);
  16809. @ @<Assign the current expression to an internal variable@>=
  16810. if cur_type=known then internal[info(lhs)-(hash_end)]:=cur_exp
  16811. else  begin exp_err("Internal quantity `");
  16812. @.Internal quantity...@>
  16813.   slow_print(int_name[info(lhs)-(hash_end)]);
  16814.   print("' must receive a known value");
  16815.   help2("I can't set an internal quantity to anything but a known")@/
  16816.     ("numeric value, so I'll have to ignore this assignment.");
  16817.   put_get_error;
  16818.   end
  16819. @ @<Assign the current expression to the variable |lhs|@>=
  16820. begin p:=find_variable(lhs);
  16821. if p<>null then
  16822.   begin q:=stash_cur_exp; cur_type:=und_type(p); recycle_value(p);
  16823.   type(p):=cur_type; value(p):=null; make_exp_copy(p);
  16824.   p:=stash_cur_exp; unstash_cur_exp(q); make_eq(p);
  16825.   end
  16826. else  begin obliterated(lhs); put_get_error;
  16827.   end;
  16828. @ And now we get to the nitty-gritty. The |make_eq| procedure is given
  16829. a pointer to a capsule that is to be equated to the current expression.
  16830. @<Declare the procedure called |make_eq|@>=
  16831. procedure make_eq(@!lhs:pointer);
  16832. label restart,done, not_found;
  16833. var @!t:small_number; {type of the left-hand side}
  16834. @!v:integer; {value of the left-hand side}
  16835. @!p,@!q:pointer; {pointers inside of big nodes}
  16836. begin restart: t:=type(lhs);
  16837. if t<=pair_type then v:=value(lhs);
  16838. case t of
  16839. @t\4@>@<For each type |t|, make an equation and |goto done| unless |cur_type|
  16840.   is incompatible with~|t|@>@;
  16841. end; {all cases have been listed}
  16842. @<Announce that the equation cannot be performed@>;
  16843. done:check_arith; recycle_value(lhs); free_node(lhs,value_node_size);
  16844. @ @<Announce that the equation cannot be performed@>=
  16845. disp_err(lhs,""); exp_err("Equation cannot be performed (");
  16846. @.Equation cannot be performed@>
  16847. if type(lhs)<=pair_type then print_type(type(lhs))@+else print("numeric");
  16848. print_char("=");
  16849. if cur_type<=pair_type then print_type(cur_type)@+else print("numeric");
  16850. print_char(")");@/
  16851. help2("I'm sorry, but I don't know how to make such things equal.")@/
  16852.   ("(See the two expressions just above the error message.)");
  16853. put_get_error
  16854. @ @<For each type |t|, make an equation and |goto done| unless...@>=
  16855. boolean_type,string_type,pen_type,path_type,picture_type:
  16856.   if cur_type=t+unknown_tag then
  16857.     begin nonlinear_eq(v,cur_exp,false); goto done;
  16858.     end
  16859.   else if cur_type=t then
  16860.     @<Report redundant or inconsistent equation and |goto done|@>;
  16861. unknown_types:if cur_type=t-unknown_tag then
  16862.     begin nonlinear_eq(cur_exp,lhs,true); goto done;
  16863.     end
  16864.   else if cur_type=t then
  16865.     begin ring_merge(lhs,cur_exp); goto done;
  16866.     end
  16867.   else if cur_type=pair_type then if t=unknown_path then
  16868.     begin pair_to_path; goto restart;
  16869.     end;
  16870. transform_type,pair_type:if cur_type=t then
  16871.     @<Do multiple equations and |goto done|@>;
  16872. known,dependent,proto_dependent,independent:if cur_type>=known then
  16873.     begin try_eq(lhs,null); goto done;
  16874.     end;
  16875. vacuous:do_nothing;
  16876. @ @<Report redundant or inconsistent equation and |goto done|@>=
  16877. begin if cur_type<=string_type then
  16878.   begin if cur_type=string_type then
  16879.     begin if str_vs_str(v,cur_exp)<>0 then goto not_found;
  16880.     end
  16881.   else if v<>cur_exp then goto not_found;
  16882.   @<Exclaim about a redundant equation@>; goto done;
  16883.   end;
  16884. print_err("Redundant or inconsistent equation");
  16885. @.Redundant or inconsistent equation@>
  16886. help2("An equation between already-known quantities can't help.")@/
  16887.   ("But don't worry; continue and I'll just ignore it.");
  16888. put_get_error; goto done;
  16889. not_found: print_err("Inconsistent equation");
  16890. @.Inconsistent equation@>
  16891. help2("The equation I just read contradicts what was said before.")@/
  16892.   ("But don't worry; continue and I'll just ignore it.");
  16893. put_get_error; goto done;
  16894. @ @<Do multiple equations and |goto done|@>=
  16895. begin p:=v+big_node_size[t]; q:=value(cur_exp)+big_node_size[t];
  16896. repeat p:=p-2; q:=q-2; try_eq(p,q);
  16897. until p=v;
  16898. goto done;
  16899. @ The first argument to |try_eq| is the location of a value node
  16900. in a capsule that will soon be recycled. The second argument is
  16901. either a location within a pair or transform node pointed to by
  16902. |cur_exp|, or it is |null| (which means that |cur_exp| itself
  16903. serves as the second argument). The idea is to leave |cur_exp| unchanged,
  16904. but to equate the two operands.
  16905. @<Declare the procedure called |try_eq|@>=
  16906. procedure try_eq(@!l,@!r:pointer);
  16907. label done,done1;
  16908. var @!p:pointer; {dependency list for right operand minus left operand}
  16909. @!t:known..independent; {the type of list |p|}
  16910. @!q:pointer; {the constant term of |p| is here}
  16911. @!pp:pointer; {dependency list for right operand}
  16912. @!tt:dependent..independent; {the type of list |pp|}
  16913. @!copied:boolean; {have we copied a list that ought to be recycled?}
  16914. begin @<Remove the left operand from its container, negate it, and
  16915.   put it into dependency list~|p| with constant term~|q|@>;
  16916. @<Add the right operand to list |p|@>;
  16917. if info(p)=null then @<Deal with redundant or inconsistent equation@>
  16918. else  begin linear_eq(p,t);
  16919.   if r=null then if cur_type<>known then if type(cur_exp)=known then
  16920.     begin pp:=cur_exp; cur_exp:=value(cur_exp); cur_type:=known;
  16921.     free_node(pp,value_node_size);
  16922.     end;
  16923.   end;
  16924. @ @<Remove the left operand from its container, negate it, and...@>=
  16925. t:=type(l);
  16926. if t=known then
  16927.   begin t:=dependent; p:=const_dependency(-value(l)); q:=p;
  16928.   end
  16929. else if t=independent then
  16930.   begin t:=dependent; p:=single_dependency(l); negate(value(p));
  16931.   q:=dep_final;
  16932.   end
  16933. else  begin p:=dep_list(l); q:=p;
  16934.   loop@+  begin negate(value(q));
  16935.     if info(q)=null then goto done;
  16936.     q:=link(q);
  16937.     end;
  16938.  done:  link(prev_dep(l)):=link(q); prev_dep(link(q)):=prev_dep(l);
  16939.   type(l):=known;
  16940.   end
  16941. @ @<Deal with redundant or inconsistent equation@>=
  16942. begin if abs(value(p))>64 then {off by .001 or more}
  16943.   begin print_err("Inconsistent equation");@/
  16944. @.Inconsistent equation@>
  16945.   print(" (off by "); print_scaled(value(p)); print_char(")");
  16946.   help2("The equation I just read contradicts what was said before.")@/
  16947.     ("But don't worry; continue and I'll just ignore it.");
  16948.   put_get_error;
  16949.   end
  16950. else if r=null then @<Exclaim about a redundant equation@>;
  16951. free_node(p,dep_node_size);
  16952. @ @<Add the right operand to list |p|@>=
  16953. if r=null then
  16954.   if cur_type=known then
  16955.     begin value(q):=value(q)+cur_exp; goto done1;
  16956.     end
  16957.   else  begin tt:=cur_type;
  16958.     if tt=independent then pp:=single_dependency(cur_exp)
  16959.     else pp:=dep_list(cur_exp);
  16960.     end
  16961. else  if type(r)=known then
  16962.     begin value(q):=value(q)+value(r); goto done1;
  16963.     end
  16964.   else  begin tt:=type(r);
  16965.     if tt=independent then pp:=single_dependency(r)
  16966.     else pp:=dep_list(r);
  16967.     end;
  16968. if tt<>independent then copied:=false
  16969. else  begin copied:=true; tt:=dependent;
  16970.   end;
  16971. @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>;
  16972. if copied then flush_node_list(pp);
  16973. done1:
  16974. @ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>=
  16975. watch_coefs:=false;
  16976. if t=tt then p:=p_plus_q(p,pp,t)
  16977. else if t=proto_dependent then
  16978.   p:=p_plus_fq(p,unity,pp,proto_dependent,dependent)
  16979. else  begin q:=p;
  16980.   while info(q)<>null do
  16981.     begin value(q):=round_fraction(value(q)); q:=link(q);
  16982.     end;
  16983.   t:=proto_dependent; p:=p_plus_q(p,pp,t);
  16984.   end;
  16985. watch_coefs:=true;
  16986. @ Our next goal is to process type declarations. For this purpose it's
  16987. convenient to have a procedure that scans a $\langle\,$declared
  16988. variable$\,\rangle$ and returns the corresponding token list. After the
  16989. following procedure has acted, the token after the declared variable
  16990. will have been scanned, so it will appear in |cur_cmd|, |cur_mod|,
  16991. and~|cur_sym|.
  16992. @<Declare the function called |scan_declared_variable|@>=
  16993. function scan_declared_variable:pointer;
  16994. label done;
  16995. var @!x:pointer; {hash address of the variable's root}
  16996. @!h,@!t:pointer; {head and tail of the token list to be returned}
  16997. @!l:pointer; {hash address of left bracket}
  16998. begin get_symbol; x:=cur_sym;
  16999. if cur_cmd<>tag_token then clear_symbol(x,false);
  17000. h:=get_avail; info(h):=x; t:=h;@/
  17001. loop@+  begin get_x_next;
  17002.   if cur_sym=0 then goto done;
  17003.   if cur_cmd<>tag_token then if cur_cmd<>internal_quantity then
  17004.     if cur_cmd=left_bracket then @<Descend past a collective subscript@>
  17005.     else goto done;
  17006.   link(t):=get_avail; t:=link(t); info(t):=cur_sym;
  17007.   end;
  17008. done: if eq_type(x)<>tag_token then clear_symbol(x,false);
  17009. if equiv(x)=null then new_root(x);
  17010. scan_declared_variable:=h;
  17011. @ If the subscript isn't collective, we don't accept it as part of the
  17012. declared variable.
  17013. @<Descend past a collective subscript@>=
  17014. begin l:=cur_sym; get_x_next;
  17015. if cur_cmd<>right_bracket then
  17016.   begin back_input; cur_sym:=l; cur_cmd:=left_bracket; goto done;
  17017.   end
  17018. else cur_sym:=collective_subscript;
  17019. @ Type declarations are introduced by the following primitive operations.
  17020. @<Put each...@>=
  17021. primitive("numeric",type_name,numeric_type);@/
  17022. @!@:numeric_}{\&{numeric} primitive@>
  17023. primitive("string",type_name,string_type);@/
  17024. @!@:string_}{\&{string} primitive@>
  17025. primitive("boolean",type_name,boolean_type);@/
  17026. @!@:boolean_}{\&{boolean} primitive@>
  17027. primitive("path",type_name,path_type);@/
  17028. @!@:path_}{\&{path} primitive@>
  17029. primitive("pen",type_name,pen_type);@/
  17030. @!@:pen_}{\&{pen} primitive@>
  17031. primitive("picture",type_name,picture_type);@/
  17032. @!@:picture_}{\&{picture} primitive@>
  17033. primitive("transform",type_name,transform_type);@/
  17034. @!@:transform_}{\&{transform} primitive@>
  17035. primitive("pair",type_name,pair_type);@/
  17036. @!@:pair_}{\&{pair} primitive@>
  17037. @ @<Cases of |print_cmd...@>=
  17038. type_name: print_type(m);
  17039. @ Now we are ready to handle type declarations, assuming that a
  17040. |type_name| has just been scanned.
  17041. @<Declare action procedures for use by |do_statement|@>=
  17042. procedure do_type_declaration;
  17043. var @!t:small_number; {the type being declared}
  17044. @!p:pointer; {token list for a declared variable}
  17045. @!q:pointer; {value node for the variable}
  17046. begin if cur_mod>=transform_type then t:=cur_mod@+else t:=cur_mod+unknown_tag;
  17047. repeat p:=scan_declared_variable;
  17048. flush_variable(equiv(info(p)),link(p),false);@/
  17049. q:=find_variable(p);
  17050. if q<>null then
  17051.   begin type(q):=t; value(q):=null;
  17052.   end
  17053. else  begin print_err("Declared variable conflicts with previous vardef");
  17054. @.Declared variable conflicts...@>
  17055.   help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")@/
  17056.     ("Proceed, and I'll ignore the illegal redeclaration.");
  17057.   put_get_error;
  17058.   end;
  17059. flush_list(p);
  17060. if cur_cmd<comma then @<Flush spurious symbols after the declared variable@>;
  17061. until end_of_statement;
  17062. @ @<Flush spurious symbols after the declared variable@>=
  17063. begin print_err("Illegal suffix of declared variable will be flushed");
  17064. @.Illegal suffix...flushed@>
  17065. help5("Variables in declarations must consist entirely of")@/
  17066.   ("names and collective subscripts, e.g., `x[]a'.")@/
  17067.   ("Are you trying to use a reserved word in a variable name?")@/
  17068.   ("I'm going to discard the junk I found here,")@/
  17069.   ("up to the next comma or the end of the declaration.");
  17070. if cur_cmd=numeric_token then
  17071.   help_line[2]:="Explicit subscripts like `x15a' aren't permitted.";
  17072. put_get_error; scanner_status:=flushing;
  17073. repeat get_next;
  17074. @<Decrease the string reference count...@>;
  17075. until cur_cmd>=comma; {either |end_of_statement| or |cur_cmd=comma|}
  17076. scanner_status:=normal;
  17077. @ \MF's |main_control| procedure just calls |do_statement| repeatedly
  17078. until coming to the end of the user's program.
  17079. Each execution of |do_statement| concludes with
  17080. |cur_cmd=semicolon|, |end_group|, or |stop|.
  17081. @p procedure main_control;
  17082. begin repeat do_statement;
  17083. if cur_cmd=end_group then
  17084.   begin print_err("Extra `endgroup'");
  17085. @.Extra `endgroup'@>
  17086.   help2("I'm not currently working on a `begingroup',")@/
  17087.     ("so I had better not try to end anything.");
  17088.   flush_error(0);
  17089.   end;
  17090. until cur_cmd=stop;
  17091. @ @<Put each...@>=
  17092. primitive("end",stop,0);@/
  17093. @!@:end_}{\&{end} primitive@>
  17094. primitive("dump",stop,1);@/
  17095. @!@:dump_}{\&{dump} primitive@>
  17096. @ @<Cases of |print_cmd...@>=
  17097. stop:if m=0 then print("end")@+else print("dump");
  17098. @* \[44] Commands.
  17099. Let's turn now to statements that are classified as ``commands'' because
  17100. of their imperative nature. We'll begin with simple ones, so that it
  17101. will be clear how to hook command processing into the |do_statement| routine;
  17102. then we'll tackle the tougher commands.
  17103. Here's one of the simplest:
  17104. @<Cases of |do_statement|...@>=
  17105. random_seed: do_random_seed;
  17106. @ @<Declare action procedures for use by |do_statement|@>=
  17107. procedure do_random_seed;
  17108. begin get_x_next;
  17109. if cur_cmd<>assignment then
  17110.   begin missing_err(":=");
  17111. @.Missing `:='@>
  17112.   help1("Always say `randomseed:=<numeric expression>'.");
  17113.   back_error;
  17114.   end;
  17115. get_x_next; scan_expression;
  17116. if cur_type<>known then
  17117.   begin exp_err("Unknown value will be ignored");
  17118. @.Unknown value...ignored@>
  17119.   help2("Your expression was too random for me to handle,")@/
  17120.     ("so I won't change the random seed just now.");@/
  17121.   put_get_flush_error(0);
  17122.   end
  17123. else @<Initialize the random seed to |cur_exp|@>;
  17124. @ @<Initialize the random seed to |cur_exp|@>=
  17125. begin init_randoms(cur_exp);
  17126. if selector>=log_only then
  17127.   begin old_setting:=selector; selector:=log_only;
  17128.   print_nl("{randomseed:="); print_scaled(cur_exp); print_char("}");
  17129.   print_nl(""); selector:=old_setting;
  17130.   end;
  17131. @ And here's another simple one (somewhat different in flavor):
  17132. @<Cases of |do_statement|...@>=
  17133. mode_command: begin print_ln; interaction:=cur_mod;
  17134.   @<Initialize the print |selector| based on |interaction|@>;
  17135.   if log_opened then selector:=selector+2;
  17136.   get_x_next;
  17137.   end;
  17138. @ @<Put each...@>=
  17139. primitive("batchmode",mode_command,batch_mode);
  17140. @!@:batch_mode_}{\&{batchmode} primitive@>
  17141. primitive("nonstopmode",mode_command,nonstop_mode);
  17142. @!@:nonstop_mode_}{\&{nonstopmode} primitive@>
  17143. primitive("scrollmode",mode_command,scroll_mode);
  17144. @!@:scroll_mode_}{\&{scrollmode} primitive@>
  17145. primitive("errorstopmode",mode_command,error_stop_mode);
  17146. @!@:error_stop_mode_}{\&{errorstopmode} primitive@>
  17147. @ @<Cases of |print_cmd_mod|...@>=
  17148. mode_command: case m of
  17149.   batch_mode: print("batchmode");
  17150.   nonstop_mode: print("nonstopmode");
  17151.   scroll_mode: print("scrollmode");
  17152.   othercases print("errorstopmode")
  17153.   endcases;
  17154. @ The `\&{inner}' and `\&{outer}' commands are only slightly harder.
  17155. @<Cases of |do_statement|...@>=
  17156. protection_command: do_protection;
  17157. @ @<Put each...@>=
  17158. primitive("inner",protection_command,0);@/
  17159. @!@:inner_}{\&{inner} primitive@>
  17160. primitive("outer",protection_command,1);@/
  17161. @!@:outer_}{\&{outer} primitive@>
  17162. @ @<Cases of |print_cmd...@>=
  17163. protection_command: if m=0 then print("inner")@+else print("outer");
  17164. @ @<Declare action procedures for use by |do_statement|@>=
  17165. procedure do_protection;
  17166. var @!m:0..1; {0 to unprotect, 1 to protect}
  17167. @!t:halfword; {the |eq_type| before we change it}
  17168. begin m:=cur_mod;
  17169. repeat get_symbol; t:=eq_type(cur_sym);
  17170.   if m=0 then
  17171.     begin if t>=outer_tag then eq_type(cur_sym):=t-outer_tag;
  17172.     end
  17173.   else if t<outer_tag then eq_type(cur_sym):=t+outer_tag;
  17174.   get_x_next;
  17175. until cur_cmd<>comma;
  17176. @ \MF\ never defines the tokens `\.(' and `\.)' to be primitives, but
  17177. plain \MF\ begins with the declaration `\&{delimiters} \.{()}'. Such a
  17178. declaration assigns the command code |left_delimiter| to `\.{(}' and
  17179. |right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the
  17180. hash address of its mate.
  17181. @<Cases of |do_statement|...@>=
  17182. delimiters: def_delims;
  17183. @ @<Declare action procedures for use by |do_statement|@>=
  17184. procedure def_delims;
  17185. var l_delim,r_delim:pointer; {the new delimiter pair}
  17186. begin get_clear_symbol; l_delim:=cur_sym;@/
  17187. get_clear_symbol; r_delim:=cur_sym;@/
  17188. eq_type(l_delim):=left_delimiter; equiv(l_delim):=r_delim;@/
  17189. eq_type(r_delim):=right_delimiter; equiv(r_delim):=l_delim;@/
  17190. get_x_next;
  17191. @ Here is a procedure that is called when \MF\ has reached a point
  17192. where some right delimiter is mandatory.
  17193. @<Declare the procedure called |check_delimiter|@>=
  17194. procedure check_delimiter(@!l_delim,@!r_delim:pointer);
  17195. label exit;
  17196. begin if cur_cmd=right_delimiter then if cur_mod=l_delim then return;
  17197. if cur_sym<>r_delim then
  17198.   begin  missing_err(text(r_delim));@/
  17199. @.Missing `)'@>
  17200.   help2("I found no right delimiter to match a left one. So I've")@/
  17201.     ("put one in, behind the scenes; this may fix the problem.");
  17202.   back_error;
  17203.   end
  17204. else  begin print_err("The token `"); slow_print(text(r_delim));
  17205. @.The token...delimiter@>
  17206.   print("' is no longer a right delimiter");
  17207.   help3("Strange: This token has lost its former meaning!")@/
  17208.     ("I'll read it as a right delimiter this time;")@/
  17209.     ("but watch out, I'll probably miss it later.");
  17210.   error;
  17211.   end;
  17212. exit:end;
  17213. @ The next four commands save or change the values associated with tokens.
  17214. @<Cases of |do_statement|...@>=
  17215. save_command: repeat get_symbol; save_variable(cur_sym); get_x_next;
  17216.   until cur_cmd<>comma;
  17217. interim_command: do_interim;
  17218. let_command: do_let;
  17219. new_internal: do_new_internal;
  17220. @ @<Declare action procedures for use by |do_statement|@>=
  17221. procedure@?do_statement; forward;@t\2@>@/
  17222. procedure do_interim;
  17223. begin get_x_next;
  17224. if cur_cmd<>internal_quantity then
  17225.   begin print_err("The token `");
  17226. @.The token...quantity@>
  17227.   if cur_sym=0 then print("(%CAPSULE)")
  17228.   else slow_print(text(cur_sym));
  17229.   print("' isn't an internal quantity");
  17230.   help1("Something like `tracingonline' should follow `interim'.");
  17231.   back_error;
  17232.   end
  17233. else  begin save_internal(cur_mod); back_input;
  17234.   end;
  17235. do_statement;
  17236. @ The following procedure is careful not to undefine the left-hand symbol
  17237. too soon, lest commands like `{\tt let x=x}' have a surprising effect.
  17238. @<Declare action procedures for use by |do_statement|@>=
  17239. procedure do_let;
  17240. var @!l:pointer; {hash location of the left-hand symbol}
  17241. begin get_symbol; l:=cur_sym; get_x_next;
  17242. if cur_cmd<>equals then if cur_cmd<>assignment then
  17243.   begin missing_err("=");
  17244. @.Missing `='@>
  17245.   help3("You should have said `let symbol = something'.")@/
  17246.     ("But don't worry; I'll pretend that an equals sign")@/
  17247.     ("was present. The next token I read will be `something'.");
  17248.   back_error;
  17249.   end;
  17250. get_symbol;
  17251. case cur_cmd of
  17252. defined_macro,secondary_primary_macro,tertiary_secondary_macro,
  17253.  expression_tertiary_macro: add_mac_ref(cur_mod);
  17254. othercases do_nothing
  17255. endcases;@/
  17256. clear_symbol(l,false); eq_type(l):=cur_cmd;
  17257. if cur_cmd=tag_token then equiv(l):=null
  17258. else equiv(l):=cur_mod;
  17259. get_x_next;
  17260. @ @<Declare action procedures for use by |do_statement|@>=
  17261. procedure do_new_internal;
  17262. begin repeat if int_ptr=max_internal then
  17263.   overflow("number of internals",max_internal);
  17264. @:METAFONT capacity exceeded number of int}{\quad number of internals@>
  17265. get_clear_symbol; incr(int_ptr);
  17266. eq_type(cur_sym):=internal_quantity; equiv(cur_sym):=int_ptr;
  17267. int_name[int_ptr]:=text(cur_sym); internal[int_ptr]:=0;
  17268. get_x_next;
  17269. until cur_cmd<>comma;
  17270. @ The various `\&{show}' commands are distinguished by modifier fields
  17271. in the usual way.
  17272. @d show_token_code=0 {show the meaning of a single token}
  17273. @d show_stats_code=1 {show current memory and string usage}
  17274. @d show_code=2 {show a list of expressions}
  17275. @d show_var_code=3 {show a variable and its descendents}
  17276. @d show_dependencies_code=4 {show dependent variables in terms of independents}
  17277. @<Put each...@>=
  17278. primitive("showtoken",show_command,show_token_code);@/
  17279. @!@:show_token_}{\&{showtoken} primitive@>
  17280. primitive("showstats",show_command,show_stats_code);@/
  17281. @!@:show_stats_}{\&{showstats} primitive@>
  17282. primitive("show",show_command,show_code);@/
  17283. @!@:show_}{\&{show} primitive@>
  17284. primitive("showvariable",show_command,show_var_code);@/
  17285. @!@:show_var_}{\&{showvariable} primitive@>
  17286. primitive("showdependencies",show_command,show_dependencies_code);@/
  17287. @!@:show_dependencies_}{\&{showdependencies} primitive@>
  17288. @ @<Cases of |print_cmd...@>=
  17289. show_command: case m of
  17290.   show_token_code:print("showtoken");
  17291.   show_stats_code:print("showstats");
  17292.   show_code:print("show");
  17293.   show_var_code:print("showvariable");
  17294.   othercases print("showdependencies")
  17295.   endcases;
  17296. @ @<Cases of |do_statement|...@>=
  17297. show_command:do_show_whatever;
  17298. @ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine:
  17299. if it's |show_code|, complicated structures are abbreviated, otherwise
  17300. they aren't.
  17301. @<Declare action procedures for use by |do_statement|@>=
  17302. procedure do_show;
  17303. begin repeat get_x_next; scan_expression;
  17304. print_nl(">> ");
  17305. @.>>@>
  17306. print_exp(null,2); flush_cur_exp(0);
  17307. until cur_cmd<>comma;
  17308. @ @<Declare action procedures for use by |do_statement|@>=
  17309. procedure disp_token;
  17310. begin print_nl("> ");
  17311. @.>\relax@>
  17312. if cur_sym=0 then @<Show a numeric or string or capsule token@>
  17313. else  begin slow_print(text(cur_sym)); print_char("=");
  17314.   if eq_type(cur_sym)>=outer_tag then print("(outer) ");
  17315.   print_cmd_mod(cur_cmd,cur_mod);
  17316.   if cur_cmd=defined_macro then
  17317.     begin print_ln; show_macro(cur_mod,null,100000);
  17318.     end; {this avoids recursion between |show_macro| and |print_cmd_mod|}
  17319. @^recursion@>
  17320.   end;
  17321. @ @<Show a numeric or string or capsule token@>=
  17322. begin if cur_cmd=numeric_token then print_scaled(cur_mod)
  17323. else if cur_cmd=capsule_token then
  17324.   begin g_pointer:=cur_mod; print_capsule;
  17325.   end
  17326. else  begin print_char(""""); slow_print(cur_mod); print_char("""");
  17327.   delete_str_ref(cur_mod);
  17328.   end;
  17329. @ The following cases of |print_cmd_mod| might arise in connection
  17330. with |disp_token|, although they don't correspond to any
  17331. primitive tokens.
  17332. @<Cases of |print_cmd_...@>=
  17333. left_delimiter,right_delimiter: begin if c=left_delimiter then print("lef")
  17334.   else print("righ");
  17335.   print("t delimiter that matches "); slow_print(text(m));
  17336.   end;
  17337. tag_token:if m=null then print("tag")@+else print("variable");
  17338. defined_macro: print("macro:");
  17339. secondary_primary_macro,tertiary_secondary_macro,expression_tertiary_macro:
  17340.   begin print_cmd_mod(macro_def,c); print("'d macro:");
  17341.   print_ln; show_token_list(link(link(m)),null,1000,0);
  17342.   end;
  17343. repeat_loop:print("[repeat the loop]");
  17344. internal_quantity:slow_print(int_name[m]);
  17345. @ @<Declare action procedures for use by |do_statement|@>=
  17346. procedure do_show_token;
  17347. begin repeat get_next; disp_token;
  17348. get_x_next;
  17349. until cur_cmd<>comma;
  17350. @ @<Declare action procedures for use by |do_statement|@>=
  17351. procedure do_show_stats;
  17352. begin print_nl("Memory usage ");
  17353. @.Memory usage...@>
  17354. @!stat print_int(var_used); print_char("&"); print_int(dyn_used);
  17355. if false then@+tats@t@>@;@/
  17356. print("unknown");
  17357. print(" ("); print_int(hi_mem_min-lo_mem_max-1);
  17358. print(" still untouched)"); print_ln;
  17359. print_nl("String usage ");
  17360. print_int(str_ptr-init_str_ptr); print_char("&");
  17361. print_int(pool_ptr-init_pool_ptr);
  17362. print(" (");
  17363. print_int(max_strings-max_str_ptr); print_char("&");
  17364. print_int(pool_size-max_pool_ptr); print(" still untouched)"); print_ln;
  17365. get_x_next;
  17366. @ Here's a recursive procedure that gives an abbreviated account
  17367. of a variable, for use by |do_show_var|.
  17368. @<Declare action procedures for use by |do_statement|@>=
  17369. procedure disp_var(@!p:pointer);
  17370. var @!q:pointer; {traverses attributes and subscripts}
  17371. @!n:0..max_print_line; {amount of macro text to show}
  17372. begin if type(p)=structured then @<Descend the structure@>
  17373. else if type(p)>=unsuffixed_macro then @<Display a variable macro@>
  17374. else if type(p)<>undefined then
  17375.   begin print_nl(""); print_variable_name(p); print_char("=");
  17376.   print_exp(p,0);
  17377.   end;
  17378. @ @<Descend the structure@>=
  17379. begin q:=attr_head(p);
  17380. repeat disp_var(q); q:=link(q);
  17381. until q=end_attr;
  17382. q:=subscr_head(p);
  17383. while name_type(q)=subscr do
  17384.   begin disp_var(q); q:=link(q);
  17385.   end;
  17386. @ @<Display a variable macro@>=
  17387. begin print_nl(""); print_variable_name(p);
  17388. if type(p)>unsuffixed_macro then print("@@#"); {|suffixed_macro|}
  17389. print("=macro:");
  17390. if file_offset>=max_print_line-20 then n:=5
  17391. else n:=max_print_line-file_offset-15;
  17392. show_macro(value(p),null,n);
  17393. @ @<Declare action procedures for use by |do_statement|@>=
  17394. procedure do_show_var;
  17395. label done;
  17396. begin repeat get_next;
  17397. if cur_sym>0 then if cur_sym<=hash_end then
  17398.  if cur_cmd=tag_token then if cur_mod<>null then
  17399.   begin disp_var(cur_mod); goto done;
  17400.   end;
  17401. disp_token;
  17402. done:get_x_next;
  17403. until cur_cmd<>comma;
  17404. @ @<Declare action procedures for use by |do_statement|@>=
  17405. procedure do_show_dependencies;
  17406. var @!p:pointer; {link that runs through all dependencies}
  17407. begin p:=link(dep_head);
  17408. while p<>dep_head do
  17409.   begin if interesting(p) then
  17410.     begin print_nl(""); print_variable_name(p);
  17411.     if type(p)=dependent then print_char("=")
  17412.     else print(" = "); {extra spaces imply proto-dependency}
  17413.     print_dependency(dep_list(p),type(p));
  17414.     end;
  17415.   p:=dep_list(p);
  17416.   while info(p)<>null do p:=link(p);
  17417.   p:=link(p);
  17418.   end;
  17419. get_x_next;
  17420. @ Finally we are ready for the procedure that governs all of the
  17421. show commands.
  17422. @<Declare action procedures for use by |do_statement|@>=
  17423. procedure do_show_whatever;
  17424. begin if interaction=error_stop_mode then wake_up_terminal;
  17425. case cur_mod of
  17426. show_token_code:do_show_token;
  17427. show_stats_code:do_show_stats;
  17428. show_code:do_show;
  17429. show_var_code:do_show_var;
  17430. show_dependencies_code:do_show_dependencies;
  17431. end; {there are no other cases}
  17432. if internal[showstopping]>0 then
  17433.   begin print_err("OK");
  17434. @.OK@>
  17435.   if interaction<error_stop_mode then
  17436.     begin help0; decr(error_count);
  17437.     end
  17438.   else help1("This isn't an error message; I'm just showing something.");
  17439.   if cur_cmd=semicolon then error@+else put_get_error;
  17440.   end;
  17441. @ The `\&{addto}' command needs the following additional primitives:
  17442. @d drop_code=0 {command modifier for `\&{dropping}'}
  17443. @d keep_code=1 {command modifier for `\&{keeping}'}
  17444. @<Put each...@>=
  17445. primitive("contour",thing_to_add,contour_code);@/
  17446. @!@:contour_}{\&{contour} primitive@>
  17447. primitive("doublepath",thing_to_add,double_path_code);@/
  17448. @!@:double_path_}{\&{doublepath} primitive@>
  17449. primitive("also",thing_to_add,also_code);@/
  17450. @!@:also_}{\&{also} primitive@>
  17451. primitive("withpen",with_option,pen_type);@/
  17452. @!@:with_pen_}{\&{withpen} primitive@>
  17453. primitive("withweight",with_option,known);@/
  17454. @!@:with_weight_}{\&{withweight} primitive@>
  17455. primitive("dropping",cull_op,drop_code);@/
  17456. @!@:dropping_}{\&{dropping} primitive@>
  17457. primitive("keeping",cull_op,keep_code);@/
  17458. @!@:keeping_}{\&{keeping} primitive@>
  17459. @ @<Cases of |print_cmd...@>=
  17460. thing_to_add:if m=contour_code then print("contour")
  17461.   else if m=double_path_code then print("doublepath")
  17462.   else print("also");
  17463. with_option:if m=pen_type then print("withpen")
  17464.   else print("withweight");
  17465. cull_op:if m=drop_code then print("dropping")
  17466.   else print("keeping");
  17467. @ @<Declare action procedures for use by |do_statement|@>=
  17468. function scan_with:boolean;
  17469. var @!t:small_number; {|known| or |pen_type|}
  17470. @!result:boolean; {the value to return}
  17471. begin t:=cur_mod; cur_type:=vacuous; get_x_next; scan_expression;
  17472. result:=false;
  17473. if cur_type<>t then @<Complain about improper type@>
  17474. else if cur_type=pen_type then result:=true
  17475. else @<Check the tentative weight@>;
  17476. scan_with:=result;
  17477. @ @<Complain about improper type@>=
  17478. begin exp_err("Improper type");
  17479. @.Improper type@>
  17480. help2("Next time say `withweight <known numeric expression>';")@/
  17481.   ("I'll ignore the bad `with' clause and look for another.");
  17482. if t=pen_type then
  17483.   help_line[1]:="Next time say `withpen <known pen expression>';";
  17484. put_get_flush_error(0);
  17485. @ @<Check the tentative weight@>=
  17486. begin cur_exp:=round_unscaled(cur_exp);
  17487. if (abs(cur_exp)<4)and(cur_exp<>0) then result:=true
  17488. else  begin print_err("Weight must be -3, -2, -1, +1, +2, or +3");
  17489. @.Weight must be...@>
  17490.   help1("I'll ignore the bad `with' clause and look for another.");
  17491.   put_get_flush_error(0);
  17492.   end;
  17493. @ One of the things we need to do when we've parsed an \&{addto} or
  17494. similar command is set |cur_edges| to the header of a supposed \&{picture}
  17495. variable, given a token list for that variable.
  17496. @<Declare action procedures for use by |do_statement|@>=
  17497. procedure find_edges_var(@!t:pointer);
  17498. var @!p:pointer;
  17499. begin p:=find_variable(t); cur_edges:=null;
  17500. if p=null then
  17501.   begin obliterated(t); put_get_error;
  17502.   end
  17503. else if type(p)<>picture_type then
  17504.   begin print_err("Variable "); show_token_list(t,null,1000,0);
  17505. @.Variable x is the wrong type@>
  17506.   print(" is the wrong type ("); print_type(type(p)); print_char(")");
  17507.   help2("I was looking for a ""known"" picture variable.")@/
  17508.     ("So I'll not change anything just now."); put_get_error;
  17509.   end
  17510. else cur_edges:=value(p);
  17511. flush_node_list(t);
  17512. @ @<Cases of |do_statement|...@>=
  17513. add_to_command: do_add_to;
  17514. @ @<Declare action procedures for use by |do_statement|@>=
  17515. procedure do_add_to;
  17516. label done, not_found;
  17517. var @!lhs,@!rhs:pointer; {variable on left, path on right}
  17518. @!w:integer; {tentative weight}
  17519. @!p:pointer; {list manipulation register}
  17520. @!q:pointer; {beginning of second half of doubled path}
  17521. @!add_to_type:double_path_code..also_code; {modifier of \&{addto}}
  17522. begin get_x_next; var_flag:=thing_to_add; scan_primary;
  17523. if cur_type<>token_list then
  17524.   @<Abandon edges command because there's no variable@>
  17525. else  begin lhs:=cur_exp; add_to_type:=cur_mod;@/
  17526.   cur_type:=vacuous; get_x_next; scan_expression;
  17527.   if add_to_type=also_code then @<Augment some edges by others@>
  17528.   else @<Get ready to fill a contour, and fill it@>;
  17529.   end;
  17530. @ @<Abandon edges command because there's no variable@>=
  17531. begin exp_err("Not a suitable variable");
  17532. @.Not a suitable variable@>
  17533. help4("At this point I needed to see the name of a picture variable.")@/
  17534.   ("(Or perhaps you have indeed presented me with one; I might")@/
  17535.   ("have missed it, if it wasn't followed by the proper token.)")@/
  17536.   ("So I'll not change anything just now.");
  17537. put_get_flush_error(0);
  17538. @ @<Augment some edges by others@>=
  17539. begin find_edges_var(lhs);
  17540. if cur_edges=null then flush_cur_exp(0)
  17541. else if cur_type<>picture_type then
  17542.   begin exp_err("Improper `addto'");
  17543. @.Improper `addto'@>
  17544.   help2("This expression should have specified a known picture.")@/
  17545.     ("So I'll not change anything just now."); put_get_flush_error(0);
  17546.   end
  17547. else  begin merge_edges(cur_exp); flush_cur_exp(0);
  17548.   end;
  17549. @ @<Get ready to fill a contour...@>=
  17550. begin if cur_type=pair_type then pair_to_path;
  17551. if cur_type<>path_type then
  17552.   begin exp_err("Improper `addto'");
  17553. @.Improper `addto'@>
  17554.   help2("This expression should have been a known path.")@/
  17555.     ("So I'll not change anything just now.");
  17556.   put_get_flush_error(0); flush_token_list(lhs);
  17557.   end
  17558. else  begin rhs:=cur_exp; w:=1; cur_pen:=null_pen;
  17559.   while cur_cmd=with_option do
  17560.     if scan_with then
  17561.       if cur_type=known then w:=cur_exp
  17562.       else @<Change the tentative pen@>;
  17563.   @<Complete the contour filling operation@>;
  17564.   delete_pen_ref(cur_pen);
  17565.   end;
  17566. @ We could say `|add_pen_ref(cur_pen)|; |flush_cur_exp(0)|' after changing
  17567. |cur_pen| here.  But that would have no effect, because the current expression
  17568. will not be flushed. Thus we save a bit of code (at the risk of being too
  17569. tricky).
  17570. @<Change the tentative pen@>=
  17571. begin delete_pen_ref(cur_pen); cur_pen:=cur_exp;
  17572. @ @<Complete the contour filling...@>=
  17573. find_edges_var(lhs);
  17574. if cur_edges=null then toss_knot_list(rhs)
  17575. else  begin lhs:=null; cur_path_type:=add_to_type;
  17576.   if left_type(rhs)=endpoint then
  17577.     if cur_path_type=double_path_code then @<Double the path@>
  17578.     else @<Complain about non-cycle and |goto not_found|@>
  17579.   else if cur_path_type=double_path_code then lhs:=htap_ypoc(rhs);
  17580.   cur_wt:=w; rhs:=make_spec(rhs,max_offset(cur_pen),internal[tracing_specs]);
  17581.   @<Check the turning number@>;
  17582.   if max_offset(cur_pen)=0 then fill_spec(rhs)
  17583.   else fill_envelope(rhs);
  17584.   if lhs<>null then
  17585.     begin rev_turns:=true;
  17586.     lhs:=make_spec(lhs,max_offset(cur_pen),internal[tracing_specs]);
  17587.     rev_turns:=false;
  17588.     if max_offset(cur_pen)=0 then fill_spec(lhs)
  17589.     else fill_envelope(lhs);
  17590.     end;
  17591. not_found: end
  17592. @ @<Double the path@>=
  17593. if link(rhs)=rhs then @<Make a trivial one-point path cycle@>
  17594. else  begin p:=htap_ypoc(rhs); q:=link(p);@/
  17595.   right_x(path_tail):=right_x(q); right_y(path_tail):=right_y(q);
  17596.   right_type(path_tail):=right_type(q);
  17597.   link(path_tail):=link(q); free_node(q,knot_node_size);@/
  17598.   right_x(p):=right_x(rhs); right_y(p):=right_y(rhs);
  17599.   right_type(p):=right_type(rhs);
  17600.   link(p):=link(rhs); free_node(rhs,knot_node_size);@/
  17601.   rhs:=p;
  17602.   end
  17603. @ @<Make a trivial one-point path cycle@>=
  17604. begin right_x(rhs):=x_coord(rhs); right_y(rhs):=y_coord(rhs);
  17605. left_x(rhs):=x_coord(rhs); left_y(rhs):=y_coord(rhs);
  17606. left_type(rhs):=explicit; right_type(rhs):=explicit;
  17607. @ @<Complain about non-cycle...@>=
  17608. begin print_err("Not a cycle");
  17609. @.Not a cycle@>
  17610. help2("That contour should have ended with `..cycle' or `&cycle'.")@/
  17611.   ("So I'll not change anything just now."); put_get_error;
  17612. toss_knot_list(rhs); goto not_found;
  17613. @ @<Check the turning number@>=
  17614. if turning_number<=0 then
  17615.  if cur_path_type<>double_path_code then if internal[turning_check]>0 then
  17616.   if (turning_number<0)and(link(cur_pen)=null) then negate(cur_wt)
  17617.   else  begin if turning_number=0 then
  17618.       if (internal[turning_check]<=unity)and(link(cur_pen)=null) then goto done
  17619.       else print_strange("Strange path (turning number is zero)")
  17620. @.Strange path...@>
  17621.     else print_strange("Backwards path (turning number is negative)");
  17622. @.Backwards path...@>
  17623.     help3("The path doesn't have a counterclockwise orientation,")@/
  17624.       ("so I'll probably have trouble drawing it.")@/
  17625.       ("(See Chapter 27 of The METAFONTbook for more help.)");
  17626. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  17627.     put_get_error;
  17628.     end;
  17629. done:
  17630. @ @<Cases of |do_statement|...@>=
  17631. ship_out_command: do_ship_out;
  17632. display_command: do_display;
  17633. open_window: do_open_window;
  17634. cull_command: do_cull;
  17635. @ @<Declare action procedures for use by |do_statement|@>=
  17636. @t\4@>@<Declare the function called |tfm_check|@>@;
  17637. procedure do_ship_out;
  17638. label exit;
  17639. var @!c:integer; {the character code}
  17640. begin get_x_next; var_flag:=semicolon; scan_expression;
  17641. if cur_type<>token_list then
  17642.   if cur_type=picture_type then cur_edges:=cur_exp
  17643.   else  begin @<Abandon edges command because there's no variable@>;
  17644.     return;
  17645.     end
  17646. else  begin find_edges_var(cur_exp); cur_type:=vacuous;
  17647.   end;
  17648. if cur_edges<>null then
  17649.   begin c:=round_unscaled(internal[char_code]) mod 256;
  17650.   if c<0 then c:=c+256;
  17651.   @<Store the width information for character code~|c|@>;
  17652.   if internal[proofing]>=0 then ship_out(c);
  17653.   end;
  17654. flush_cur_exp(0);
  17655. exit:end;
  17656. @ @<Declare action procedures for use by |do_statement|@>=
  17657. procedure do_display;
  17658. label not_found,common_ending,exit;
  17659. var @!e:pointer; {token list for a picture variable}
  17660. begin get_x_next; var_flag:=in_window; scan_primary;
  17661. if cur_type<>token_list then
  17662.   @<Abandon edges command because there's no variable@>
  17663. else  begin e:=cur_exp; cur_type:=vacuous;
  17664.   get_x_next; scan_expression;
  17665.   if cur_type<>known then goto common_ending;
  17666.   cur_exp:=round_unscaled(cur_exp);
  17667.   if cur_exp<0 then goto not_found;
  17668.   if cur_exp>15 then goto not_found;
  17669.   if not window_open[cur_exp] then goto not_found;
  17670.   find_edges_var(e);
  17671.   if cur_edges<>null then disp_edges(cur_exp);
  17672.   return;
  17673.  not_found: cur_exp:=cur_exp*unity;
  17674.  common_ending: exp_err("Bad window number");
  17675. @.Bad window number@>
  17676.   help1("It should be the number of an open window.");
  17677.   put_get_flush_error(0); flush_token_list(e);
  17678.   end;
  17679. exit:end;
  17680. @ The only thing difficult about `\&{openwindow}' is that the syntax
  17681. allows the user to go astray in many ways. The following subroutine
  17682. helps keep the necessary program reasonably short and sweet.
  17683. @<Declare action procedures for use by |do_statement|@>=
  17684. function get_pair(@!c:command_code):boolean;
  17685. var @!p:pointer; {a pair of values that are known (we hope)}
  17686. @!b:boolean; {did we find such a pair?}
  17687. begin if cur_cmd<>c then get_pair:=false
  17688. else  begin get_x_next; scan_expression;
  17689.   if nice_pair(cur_exp,cur_type) then
  17690.     begin p:=value(cur_exp);
  17691.     cur_x:=value(x_part_loc(p)); cur_y:=value(y_part_loc(p));
  17692.     b:=true;
  17693.     end
  17694.   else b:=false;
  17695.   flush_cur_exp(0); get_pair:=b;
  17696.   end;
  17697. @ @<Declare action procedures for use by |do_statement|@>=
  17698. procedure do_open_window;
  17699. label not_found,exit;
  17700. var @!k:integer; {the window number in question}
  17701. @!r0,@!c0,@!r1,@!c1:scaled; {window coordinates}
  17702. begin get_x_next; scan_expression;
  17703. if cur_type<>known then goto not_found;
  17704. k:=round_unscaled(cur_exp);
  17705. if k<0 then goto not_found;
  17706. if k>15 then goto not_found;
  17707. if not get_pair(from_token) then goto not_found;
  17708. r0:=cur_x; c0:=cur_y;
  17709. if not get_pair(to_token) then goto not_found;
  17710. r1:=cur_x; c1:=cur_y;
  17711. if not get_pair(at_token) then goto not_found;
  17712. open_a_window(k,r0,c0,r1,c1,cur_x,cur_y); return;
  17713. not_found:print_err("Improper `openwindow'");
  17714. @.Improper `openwindow'@>
  17715. help2("Say `openwindow k from (r0,c0) to (r1,c1) at (x,y)',")@/
  17716.   ("where all quantities are known and k is between 0 and 15.");
  17717. put_get_error;
  17718. exit:end;
  17719. @ @<Declare action procedures for use by |do_statement|@>=
  17720. procedure do_cull;
  17721. label not_found,exit;
  17722. var @!e:pointer; {token list for a picture variable}
  17723. @!keeping:drop_code..keep_code; {modifier of |cull_op|}
  17724. @!w,@!w_in,@!w_out:integer; {culling weights}
  17725. begin w:=1;
  17726. get_x_next; var_flag:=cull_op; scan_primary;
  17727. if cur_type<>token_list then
  17728.   @<Abandon edges command because there's no variable@>
  17729. else  begin e:=cur_exp; cur_type:=vacuous; keeping:=cur_mod;
  17730.   if not get_pair(cull_op) then goto not_found;
  17731.   while (cur_cmd=with_option)and(cur_mod=known) do
  17732.     if scan_with then w:=cur_exp;
  17733.   @<Set up the culling weights,
  17734.     or |goto not_found| if the thresholds are bad@>;
  17735.   find_edges_var(e);
  17736.   if cur_edges<>null then
  17737.     cull_edges(floor_unscaled(cur_x+unity-1),floor_unscaled(cur_y),w_out,w_in);
  17738.   return;
  17739.  not_found: print_err("Bad culling amounts");
  17740. @.Bad culling amounts@>
  17741.   help1("Always cull by known amounts that exclude 0.");
  17742.   put_get_error; flush_token_list(e);
  17743.   end;
  17744. exit:end;
  17745. @ @<Set up the culling weights, or |goto not_found| if the thresholds are bad@>=
  17746. if cur_x>cur_y then goto not_found;
  17747. if keeping=drop_code then
  17748.   begin if (cur_x>0)or(cur_y<0) then goto not_found;
  17749.   w_out:=w; w_in:=0;
  17750.   end
  17751. else  begin if (cur_x<=0)and(cur_y>=0) then goto not_found;
  17752.   w_out:=0; w_in:=w;
  17753.   end
  17754. @ The \&{everyjob} command simply assigns a nonzero value to the global variable
  17755. |start_sym|.
  17756. @<Cases of |do_statement|...@>=
  17757. every_job_command: begin get_symbol; start_sym:=cur_sym; get_x_next;
  17758.   end;
  17759. @ @<Glob...@>=
  17760. @!start_sym:halfword; {a symbolic token to insert at beginning of job}
  17761. @ @<Set init...@>=
  17762. start_sym:=0;
  17763. @ Finally, we have only the ``message'' commands remaining.
  17764. @d message_code=0
  17765. @d err_message_code=1
  17766. @d err_help_code=2
  17767. @<Put each...@>=
  17768. primitive("message",message_command,message_code);@/
  17769. @!@:message_}{\&{message} primitive@>
  17770. primitive("errmessage",message_command,err_message_code);@/
  17771. @!@:err_message_}{\&{errmessage} primitive@>
  17772. primitive("errhelp",message_command,err_help_code);@/
  17773. @!@:err_help_}{\&{errhelp} primitive@>
  17774. @ @<Cases of |print_cmd...@>=
  17775. message_command: if m<err_message_code then print("message")
  17776.   else if m=err_message_code then print("errmessage")
  17777.   else print("errhelp");
  17778. @ @<Cases of |do_statement|...@>=
  17779. message_command: do_message;
  17780. @ @<Declare action procedures for use by |do_statement|@>=
  17781. procedure do_message;
  17782. var @!m:message_code..err_help_code; {the type of message}
  17783. begin m:=cur_mod; get_x_next; scan_expression;
  17784. if cur_type<>string_type then
  17785.   begin exp_err("Not a string");
  17786. @.Not a string@>
  17787.   help1("A message should be a known string expression.");
  17788.   put_get_error;
  17789.   end
  17790. else  case m of
  17791.   message_code:begin print_nl(""); slow_print(cur_exp);
  17792.     end;
  17793.   err_message_code:@<Print string |cur_exp| as an error message@>;
  17794.   err_help_code:@<Save string |cur_exp| as the |err_help|@>;
  17795.   end; {there are no other cases}
  17796. flush_cur_exp(0);
  17797. @ The global variable |err_help| is zero when the user has most recently
  17798. given an empty help string, or if none has ever been given.
  17799. @<Save string |cur_exp| as the |err_help|@>=
  17800. begin if err_help<>0 then delete_str_ref(err_help);
  17801. if length(cur_exp)=0 then err_help:=0
  17802. else  begin err_help:=cur_exp; add_str_ref(err_help);
  17803.   end;
  17804. @ If \&{errmessage} occurs often in |scroll_mode|, without user-defined
  17805. \&{errhelp}, we don't want to give a long help message each time. So we
  17806. give a verbose explanation only once.
  17807. @<Glob...@>=
  17808. @!long_help_seen:boolean; {has the long \.{\\errmessage} help been used?}
  17809. @ @<Set init...@>=long_help_seen:=false;
  17810. @ @<Print string |cur_exp| as an error message@>=
  17811. begin print_err(""); slow_print(cur_exp);
  17812. if err_help<>0 then use_err_help:=true
  17813. else if long_help_seen then help1("(That was another `errmessage'.)")
  17814. else  begin if interaction<error_stop_mode then long_help_seen:=true;
  17815.   help4("This error message was generated by an `errmessage'")@/
  17816.   ("command, so I can't give any explicit help.")@/
  17817.   ("Pretend that you're Miss Marple: Examine all clues,")@/
  17818. @^Marple, Jane@>
  17819.   ("and deduce the truth by inspired guesses.");
  17820.   end;
  17821. put_get_error; use_err_help:=false;
  17822. @* \[45] Font metric data.
  17823. \TeX\ gets its knowledge about fonts from font metric files, also called
  17824. \.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX,
  17825. but other programs know about them too. One of \MF's duties is to
  17826. write \.{TFM} files so that the user's fonts can readily be
  17827. applied to typesetting.
  17828. @:TFM files}{\.{TFM} files@>
  17829. @^font metric files@>
  17830. The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
  17831. Since the number of bytes is always a multiple of~4, we could
  17832. also regard the file as a sequence of 32-bit words, but \MF\ uses the
  17833. byte interpretation. The format of \.{TFM} files was designed by
  17834. Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds
  17835. @^Ramshaw, Lyle Harold@>
  17836. of information in a compact but useful form.
  17837. @<Glob...@>=
  17838. @!tfm_file:byte_file; {the font metric output goes here}
  17839. @!metric_file_name: str_number; {full name of the font metric file}
  17840. @ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
  17841. integers that give the lengths of the various subsequent portions
  17842. of the file. These twelve integers are, in order:
  17843. $$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
  17844. |lf|&length of the entire file, in words;\cr
  17845. |lh|&length of the header data, in words;\cr
  17846. |bc|&smallest character code in the font;\cr
  17847. |ec|&largest character code in the font;\cr
  17848. |nw|&number of words in the width table;\cr
  17849. |nh|&number of words in the height table;\cr
  17850. |nd|&number of words in the depth table;\cr
  17851. |ni|&number of words in the italic correction table;\cr
  17852. |nl|&number of words in the lig/kern table;\cr
  17853. |nk|&number of words in the kern table;\cr
  17854. |ne|&number of words in the extensible character table;\cr
  17855. |np|&number of font parameter words.\cr}}$$
  17856. They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
  17857. |ne<=256|, and
  17858. $$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
  17859. Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
  17860. and as few as 0 characters (if |bc=ec+1|).
  17861. Incidentally, when two or more 8-bit bytes are combined to form an integer of
  17862. 16 or more bits, the most significant bytes appear first in the file.
  17863. This is called BigEndian order.
  17864. @!@^BigEndian order@>
  17865. @ The rest of the \.{TFM} file may be regarded as a sequence of ten data
  17866. arrays having the informal specification
  17867. $$\def\arr$[#1]#2${\&{array} $[#1]$ \&{of} #2}
  17868. \tabskip\centering
  17869. \halign to\displaywidth{\hfil\\{#}\tabskip=0pt&$\,:\,$\arr#\hfil
  17870.  \tabskip\centering\cr
  17871. header&|[0..lh-1]@t\\{stuff}@>|\cr
  17872. char\_info&|[bc..ec]char_info_word|\cr
  17873. width&|[0..nw-1]fix_word|\cr
  17874. height&|[0..nh-1]fix_word|\cr
  17875. depth&|[0..nd-1]fix_word|\cr
  17876. italic&|[0..ni-1]fix_word|\cr
  17877. lig\_kern&|[0..nl-1]lig_kern_command|\cr
  17878. kern&|[0..nk-1]fix_word|\cr
  17879. exten&|[0..ne-1]extensible_recipe|\cr
  17880. param&|[1..np]fix_word|\cr}$$
  17881. The most important data type used here is a |@!fix_word|, which is
  17882. a 32-bit representation of a binary fraction. A |fix_word| is a signed
  17883. quantity, with the two's complement of the entire word used to represent
  17884. negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
  17885. binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
  17886. the smallest is $-2048$. We will see below, however, that all but two of
  17887. the |fix_word| values must lie between $-16$ and $+16$.
  17888. @ The first data array is a block of header information, which contains
  17889. general facts about the font. The header must contain at least two words,
  17890. |header[0]| and |header[1]|, whose meaning is explained below.  Additional
  17891. header information of use to other software routines might also be
  17892. included, and \MF\ will generate it if the \.{headerbyte} command occurs.
  17893. For example, 16 more words of header information are in use at the Xerox
  17894. Palo Alto Research Center; the first ten specify the character coding
  17895. scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five
  17896. give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the
  17897. last gives the ``face byte.''
  17898. \yskip\hang|header[0]| is a 32-bit check sum that \MF\ will copy into
  17899. the \.{GF} output file. This helps ensure consistency between files,
  17900. since \TeX\ records the check sums from the \.{TFM}'s it reads, and these
  17901. should match the check sums on actual fonts that are used.  The actual
  17902. relation between this check sum and the rest of the \.{TFM} file is not
  17903. important; the check sum is simply an identification number with the
  17904. property that incompatible fonts almost always have distinct check sums.
  17905. @^check sum@>
  17906. \yskip\hang|header[1]| is a |fix_word| containing the design size of the
  17907. font, in units of \TeX\ points. This number must be at least 1.0; it is
  17908. fairly arbitrary, but usually the design size is 10.0 for a ``10 point''
  17909. font, i.e., a font that was designed to look best at a 10-point size,
  17910. whatever that really means. When a \TeX\ user asks for a font `\.{at}
  17911. $\delta$ \.{pt}', the effect is to override the design size and replace it
  17912. by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in
  17913. the font image by a factor of $\delta$ divided by the design size.  {\sl
  17914. All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\
  17915. numbers in design-size units.} Thus, for example, the value of |param[6]|,
  17916. which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$,
  17917. since many fonts have a design size equal to one em.  The other dimensions
  17918. must be less than 16 design-size units in absolute value; thus,
  17919. |header[1]| and |param[1]| are the only |fix_word| entries in the whole
  17920. \.{TFM} file whose first byte might be something besides 0 or 255.
  17921. @ Next comes the |char_info| array, which contains one |@!char_info_word|
  17922. per character. Each word in this part of the file contains six fields
  17923. packed into four bytes as follows.
  17924. \yskip\hang first byte: |@!width_index| (8 bits)\par
  17925. \hang second byte: |@!height_index| (4 bits) times 16, plus |@!depth_index|
  17926.   (4~bits)\par
  17927. \hang third byte: |@!italic_index| (6 bits) times 4, plus |@!tag|
  17928.   (2~bits)\par
  17929. \hang fourth byte: |@!remainder| (8 bits)\par
  17930. \yskip\noindent
  17931. The actual width of a character is \\{width}|[width_index]|, in design-size
  17932. units; this is a device for compressing information, since many characters
  17933. have the same width. Since it is quite common for many characters
  17934. to have the same height, depth, or italic correction, the \.{TFM} format
  17935. imposes a limit of 16 different heights, 16 different depths, and
  17936. 64 different italic corrections.
  17937. Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]=
  17938. \\{italic}[0]=0$ should always hold, so that an index of zero implies a
  17939. value of zero.  The |width_index| should never be zero unless the
  17940. character does not exist in the font, since a character is valid if and
  17941. only if it lies between |bc| and |ec| and has a nonzero |width_index|.
  17942. @ The |tag| field in a |char_info_word| has four values that explain how to
  17943. interpret the |remainder| field.
  17944. \yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
  17945. \hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
  17946. program starting at location |remainder| in the |lig_kern| array.\par
  17947. \hang|tag=2| (|list_tag|) means that this character is part of a chain of
  17948. characters of ascending sizes, and not the largest in the chain.  The
  17949. |remainder| field gives the character code of the next larger character.\par
  17950. \hang|tag=3| (|ext_tag|) means that this character code represents an
  17951. extensible character, i.e., a character that is built up of smaller pieces
  17952. so that it can be made arbitrarily large. The pieces are specified in
  17953. |@!exten[remainder]|.\par
  17954. \yskip\noindent
  17955. Characters with |tag=2| and |tag=3| are treated as characters with |tag=0|
  17956. unless they are used in special circumstances in math formulas. For example,
  17957. \TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left}
  17958. operation looks for both |list_tag| and |ext_tag|.
  17959. @d no_tag=0 {vanilla character}
  17960. @d lig_tag=1 {character has a ligature/kerning program}
  17961. @d list_tag=2 {character has a successor in a charlist}
  17962. @d ext_tag=3 {character is extensible}
  17963. @ The |lig_kern| array contains instructions in a simple programming language
  17964. that explains what to do for special letter pairs. Each word in this array is a
  17965. |@!lig_kern_command| of four bytes.
  17966. \yskip\hang first byte: |skip_byte|, indicates that this is the final program
  17967.   step if the byte is 128 or more, otherwise the next step is obtained by
  17968.   skipping this number of intervening steps.\par
  17969. \hang second byte: |next_char|, ``if |next_char| follows the current character,
  17970.   then perform the operation and stop, otherwise continue.''\par
  17971. \hang third byte: |op_byte|, indicates a ligature step if less than~128,
  17972.   a kern step otherwise.\par
  17973. \hang fourth byte: |remainder|.\par
  17974. \yskip\noindent
  17975. In a kern step, an
  17976. additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
  17977. between the current character and |next_char|. This amount is
  17978. often negative, so that the characters are brought closer together
  17979. by kerning; but it might be positive.
  17980. There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
  17981. $0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
  17982. |remainder| is inserted between the current character and |next_char|;
  17983. then the current character is deleted if $b=0$, and |next_char| is
  17984. deleted if $c=0$; then we pass over $a$~characters to reach the next
  17985. current character (which may have a ligature/kerning program of its own).
  17986. If the very first instruction of the |lig_kern| array has |skip_byte=255|,
  17987. the |next_char| byte is the so-called right boundary character of this font;
  17988. the value of |next_char| need not lie between |bc| and~|ec|.
  17989. If the very last instruction of the |lig_kern| array has |skip_byte=255|,
  17990. there is a special ligature/kerning program for a left boundary character,
  17991. beginning at location |256*op_byte+remainder|.
  17992. The interpretation is that \TeX\ puts implicit boundary characters
  17993. before and after each consecutive string of characters from the same font.
  17994. These implicit characters do not appear in the output, but they can affect
  17995. ligatures and kerning.
  17996. If the very first instruction of a character's |lig_kern| program has
  17997. |skip_byte>128|, the program actually begins in location
  17998. |256*op_byte+remainder|. This feature allows access to large |lig_kern|
  17999. arrays, because the first instruction must otherwise
  18000. appear in a location |<=255|.
  18001. Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy
  18002. the condition
  18003. $$\hbox{|256*op_byte+remainder<nl|.}$$
  18004. If such an instruction is encountered during
  18005. normal program execution, it denotes an unconditional halt; no ligature
  18006. command is performed.
  18007. @d stop_flag=128+min_quarterword
  18008.   {value indicating `\.{STOP}' in a lig/kern program}
  18009. @d kern_flag=128+min_quarterword {op code for a kern step}
  18010. @d skip_byte(#)==lig_kern[#].b0
  18011. @d next_char(#)==lig_kern[#].b1
  18012. @d op_byte(#)==lig_kern[#].b2
  18013. @d rem_byte(#)==lig_kern[#].b3
  18014. @ Extensible characters are specified by an |@!extensible_recipe|, which
  18015. consists of four bytes called |@!top|, |@!mid|, |@!bot|, and |@!rep| (in this
  18016. order). These bytes are the character codes of individual pieces used to
  18017. build up a large symbol.  If |top|, |mid|, or |bot| are zero, they are not
  18018. present in the built-up result. For example, an extensible vertical line is
  18019. like an extensible bracket, except that the top and bottom pieces are missing.
  18020. Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box
  18021. if the piece isn't present. Then the extensible characters have the form
  18022. $TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent;
  18023. in the latter case we can have $TR^kB$ for both even and odd values of~|k|.
  18024. The width of the extensible character is the width of $R$; and the
  18025. height-plus-depth is the sum of the individual height-plus-depths of the
  18026. components used, since the pieces are butted together in a vertical list.
  18027. @d ext_top(#)==exten[#].b0 {|top| piece in a recipe}
  18028. @d ext_mid(#)==exten[#].b1 {|mid| piece in a recipe}
  18029. @d ext_bot(#)==exten[#].b2 {|bot| piece in a recipe}
  18030. @d ext_rep(#)==exten[#].b3 {|rep| piece in a recipe}
  18031. @ The final portion of a \.{TFM} file is the |param| array, which is another
  18032. sequence of |fix_word| values.
  18033. \yskip\hang|param[1]=slant| is the amount of italic slant, which is used
  18034. to help position accents. For example, |slant=.25| means that when you go
  18035. up one unit, you also go .25 units to the right. The |slant| is a pure
  18036. number; it is the only |fix_word| other than the design size itself that is
  18037. not scaled by the design size.
  18038. \hang|param[2]=space| is the normal spacing between words in text.
  18039. Note that character @'40 in the font need not have anything to do with
  18040. blank spaces.
  18041. \hang|param[3]=space_stretch| is the amount of glue stretching between words.
  18042. \hang|param[4]=space_shrink| is the amount of glue shrinking between words.
  18043. \hang|param[5]=x_height| is the size of one ex in the font; it is also
  18044. the height of letters for which accents don't have to be raised or lowered.
  18045. \hang|param[6]=quad| is the size of one em in the font.
  18046. \hang|param[7]=extra_space| is the amount added to |param[2]| at the
  18047. ends of sentences.
  18048. \yskip\noindent
  18049. If fewer than seven parameters are present, \TeX\ sets the missing parameters
  18050. to zero.
  18051. @d slant_code=1
  18052. @d space_code=2
  18053. @d space_stretch_code=3
  18054. @d space_shrink_code=4
  18055. @d x_height_code=5
  18056. @d quad_code=6
  18057. @d extra_space_code=7
  18058. @ So that is what \.{TFM} files hold. One of \MF's duties is to output such
  18059. information, and it does this all at once at the end of a job.
  18060. In order to prepare for such frenetic activity, it squirrels away the
  18061. necessary facts in various arrays as information becomes available.
  18062. Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic})
  18063. are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and
  18064. |tfm_ital_corr|. Other information about a character (e.g., about
  18065. its ligatures or successors) is accessible via the |char_tag| and
  18066. |char_remainder| arrays. Other information about the font as a whole
  18067. is kept in additional arrays called |header_byte|, |lig_kern|,
  18068. |kern|, |exten|, and |param|.
  18069. @d undefined_label==lig_table_size {an undefined local label}
  18070. @<Glob...@>=
  18071. @!bc,@!ec:eight_bits; {smallest and largest character codes shipped out}
  18072. @!tfm_width:array[eight_bits] of scaled; {\&{charwd} values}
  18073. @!tfm_height:array[eight_bits] of scaled; {\&{charht} values}
  18074. @!tfm_depth:array[eight_bits] of scaled; {\&{chardp} values}
  18075. @!tfm_ital_corr:array[eight_bits] of scaled; {\&{charic} values}
  18076. @!char_exists:array[eight_bits] of boolean; {has this code been shipped out?}
  18077. @!char_tag:array[eight_bits] of no_tag..ext_tag; {|remainder| category}
  18078. @!char_remainder:array[eight_bits] of 0..lig_table_size; {the |remainder| byte}
  18079. @!header_byte:array[1..header_size] of -1..255;
  18080.   {bytes of the \.{TFM} header, or $-1$ if unset}
  18081. @!lig_kern:array[0..lig_table_size] of four_quarters; {the ligature/kern table}
  18082. @!nl:0..32767-256; {the number of ligature/kern steps so far}
  18083. @!kern:array[0..max_kerns] of scaled; {distinct kerning amounts}
  18084. @!nk:0..max_kerns; {the number of distinct kerns so far}
  18085. @!exten:array[eight_bits] of four_quarters; {extensible character recipes}
  18086. @!ne:0..256; {the number of extensible characters so far}
  18087. @!param:array[1..max_font_dimen] of scaled; {\&{fontinfo} parameters}
  18088. @!np:0..max_font_dimen; {the largest \&{fontinfo} parameter specified so far}
  18089. @!nw,@!nh,@!nd,@!ni:0..256; {sizes of \.{TFM} subtables}
  18090. @!skip_table:array[eight_bits] of 0..lig_table_size; {local label status}
  18091. @!lk_started:boolean; {has there been a lig/kern step in this command yet?}
  18092. @!bchar:integer; {right boundary character}
  18093. @!bch_label:0..lig_table_size; {left boundary starting location}
  18094. @!ll,@!lll:0..lig_table_size; {registers used for lig/kern processing}
  18095. @!label_loc:array[0..256] of -1..lig_table_size; {lig/kern starting addresses}
  18096. @!label_char:array[1..256] of eight_bits; {characters for |label_loc|}
  18097. @!label_ptr:0..256; {highest position occupied in |label_loc|}
  18098. @ @<Set init...@>=
  18099. for k:=0 to 255 do
  18100.   begin tfm_width[k]:=0; tfm_height[k]:=0; tfm_depth[k]:=0; tfm_ital_corr[k]:=0;
  18101.   char_exists[k]:=false; char_tag[k]:=no_tag; char_remainder[k]:=0;
  18102.   skip_table[k]:=undefined_label;
  18103.   end;
  18104. for k:=1 to header_size do header_byte[k]:=-1;
  18105. bc:=255; ec:=0; nl:=0; nk:=0; ne:=0; np:=0;@/
  18106. internal[boundary_char]:=-unity;
  18107. bch_label:=undefined_label;@/
  18108. label_loc[0]:=-1; label_ptr:=0;
  18109. @ @<Declare the function called |tfm_check|@>=
  18110. function tfm_check(@!m:small_number):scaled;
  18111. begin if abs(internal[m])>=fraction_half then
  18112.   begin print_err("Enormous "); print(int_name[m]);
  18113. @.Enormous charwd...@>
  18114. @.Enormous chardp...@>
  18115. @.Enormous charht...@>
  18116. @.Enormous charic...@>
  18117. @.Enormous designsize...@>
  18118.   print(" has been reduced");
  18119.   help1("Font metric dimensions must be less than 2048pt.");
  18120.   put_get_error;
  18121.   if internal[m]>0 then tfm_check:=fraction_half-1
  18122.   else tfm_check:=1-fraction_half;
  18123.   end
  18124. else tfm_check:=internal[m];
  18125. @ @<Store the width information for character code~|c|@>=
  18126. if c<bc then bc:=c;
  18127. if c>ec then ec:=c;
  18128. char_exists[c]:=true;
  18129. gf_dx[c]:=internal[char_dx]; gf_dy[c]:=internal[char_dy];
  18130. tfm_width[c]:=tfm_check(char_wd);
  18131. tfm_height[c]:=tfm_check(char_ht);
  18132. tfm_depth[c]:=tfm_check(char_dp);
  18133. tfm_ital_corr[c]:=tfm_check(char_ic)
  18134. @ Now let's consider \MF's special \.{TFM}-oriented commands.
  18135. @<Cases of |do_statement|...@>=
  18136. tfm_command: do_tfm_command;
  18137. @ @d char_list_code=0
  18138. @d lig_table_code=1
  18139. @d extensible_code=2
  18140. @d header_byte_code=3
  18141. @d font_dimen_code=4
  18142. @<Put each...@>=
  18143. primitive("charlist",tfm_command,char_list_code);@/
  18144. @!@:char_list_}{\&{charlist} primitive@>
  18145. primitive("ligtable",tfm_command,lig_table_code);@/
  18146. @!@:lig_table_}{\&{ligtable} primitive@>
  18147. primitive("extensible",tfm_command,extensible_code);@/
  18148. @!@:extensible_}{\&{extensible} primitive@>
  18149. primitive("headerbyte",tfm_command,header_byte_code);@/
  18150. @!@:header_byte_}{\&{headerbyte} primitive@>
  18151. primitive("fontdimen",tfm_command,font_dimen_code);@/
  18152. @!@:font_dimen_}{\&{fontdimen} primitive@>
  18153. @ @<Cases of |print_cmd...@>=
  18154. tfm_command: case m of
  18155.   char_list_code:print("charlist");
  18156.   lig_table_code:print("ligtable");
  18157.   extensible_code:print("extensible");
  18158.   header_byte_code:print("headerbyte");
  18159.   othercases print("fontdimen")
  18160.   endcases;
  18161. @ @<Declare action procedures for use by |do_statement|@>=
  18162. function get_code:eight_bits; {scans a character code value}
  18163. label found;
  18164. var @!c:integer; {the code value found}
  18165. begin get_x_next; scan_expression;
  18166. if cur_type=known then
  18167.   begin c:=round_unscaled(cur_exp);
  18168.   if c>=0 then if c<256 then goto found;
  18169.   end
  18170. else if cur_type=string_type then if length(cur_exp)=1 then
  18171.   begin c:=so(str_pool[str_start[cur_exp]]); goto found;
  18172.   end;
  18173. exp_err("Invalid code has been replaced by 0");
  18174. @.Invalid code...@>
  18175. help2("I was looking for a number between 0 and 255, or for a")@/
  18176.   ("string of length 1. Didn't find it; will use 0 instead.");
  18177. put_get_flush_error(0); c:=0;
  18178. found: get_code:=c;
  18179. @ @<Declare action procedures for use by |do_statement|@>=
  18180. procedure set_tag(@!c:halfword;@!t:small_number;@!r:halfword);
  18181. begin if char_tag[c]=no_tag then
  18182.   begin char_tag[c]:=t; char_remainder[c]:=r;
  18183.   if t=lig_tag then
  18184.     begin incr(label_ptr); label_loc[label_ptr]:=r; label_char[label_ptr]:=c;
  18185.     end;
  18186.   end
  18187. else @<Complain about a character tag conflict@>;
  18188. @ @<Complain about a character tag conflict@>=
  18189. begin print_err("Character ");
  18190. if (c>" ")and(c<127) then print(c)
  18191. else if c=256 then print("||")
  18192. else  begin print("code "); print_int(c);
  18193.   end;
  18194. print(" is already ");
  18195. @.Character c is already...@>
  18196. case char_tag[c] of
  18197. lig_tag: print("in a ligtable");
  18198. list_tag: print("in a charlist");
  18199. ext_tag: print("extensible");
  18200. end; {there are no other cases}
  18201. help2("It's not legal to label a character more than once.")@/
  18202.   ("So I'll not change anything just now.");
  18203. put_get_error; end
  18204. @ @<Declare action procedures for use by |do_statement|@>=
  18205. procedure do_tfm_command;
  18206. label continue,done;
  18207. var @!c,@!cc:0..256; {character codes}
  18208. @!k:0..max_kerns; {index into the |kern| array}
  18209. @!j:integer; {index into |header_byte| or |param|}
  18210. begin case cur_mod of
  18211. char_list_code: begin c:=get_code;
  18212.      {we will store a list of character successors}
  18213.   while cur_cmd=colon do
  18214.     begin cc:=get_code; set_tag(c,list_tag,cc); c:=cc;
  18215.     end;
  18216.   end;
  18217. lig_table_code: @<Store a list of ligature/kern steps@>;
  18218. extensible_code: @<Define an extensible recipe@>;
  18219. header_byte_code, font_dimen_code: begin c:=cur_mod; get_x_next;
  18220.   scan_expression;
  18221.   if (cur_type<>known)or(cur_exp<half_unit) then
  18222.     begin exp_err("Improper location");
  18223. @.Improper location@>
  18224.     help2("I was looking for a known, positive number.")@/
  18225.       ("For safety's sake I'll ignore the present command.");
  18226.     put_get_error;
  18227.     end
  18228.   else  begin j:=round_unscaled(cur_exp);
  18229.     if cur_cmd<>colon then
  18230.       begin missing_err(":");
  18231. @.Missing `:'@>
  18232.       help1("A colon should follow a headerbyte or fontinfo location.");
  18233.       back_error;
  18234.       end;
  18235.     if c=header_byte_code then @<Store a list of header bytes@>
  18236.     else @<Store a list of font dimensions@>;
  18237.     end;
  18238.   end;
  18239. end; {there are no other cases}
  18240. @ @<Store a list of ligature/kern steps@>=
  18241. begin lk_started:=false;
  18242. continue: get_x_next;
  18243. if(cur_cmd=skip_to)and lk_started then
  18244.  @<Process a |skip_to| command and |goto done|@>;
  18245. if cur_cmd=bchar_label then
  18246.   begin c:=256; cur_cmd:=colon;@+end
  18247. else begin back_input; c:=get_code;@+end;
  18248. if(cur_cmd=colon)or(cur_cmd=double_colon)then
  18249.   @<Record a label in a lig/kern subprogram and |goto continue|@>;
  18250. if cur_cmd=lig_kern_token then @<Compile a ligature/kern command@>
  18251. else  begin print_err("Illegal ligtable step");
  18252. @.Illegal ligtable step@>
  18253.   help1("I was looking for `=:' or `kern' here.");
  18254.   back_error; next_char(nl):=qi(0); op_byte(nl):=qi(0); rem_byte(nl):=qi(0);@/
  18255.   skip_byte(nl):=stop_flag+1; {this specifies an unconditional stop}
  18256.   end;
  18257. if nl=lig_table_size then overflow("ligtable size",lig_table_size);
  18258. @:METAFONT capacity exceeded ligtable size}{\quad ligtable size@>
  18259. incr(nl);
  18260. if cur_cmd=comma then goto continue;
  18261. if skip_byte(nl-1)<stop_flag then skip_byte(nl-1):=stop_flag;
  18262. done:end
  18263. @ @<Put each...@>=
  18264. primitive("=:",lig_kern_token,0);
  18265. @!@:=:_}{\.{=:} primitive@>
  18266. primitive("=:|",lig_kern_token,1);
  18267. @!@:=:/_}{\.{=:\char'174} primitive@>
  18268. primitive("=:|>",lig_kern_token,5);
  18269. @!@:=:/>_}{\.{=:\char'174>} primitive@>
  18270. primitive("|=:",lig_kern_token,2);
  18271. @!@:=:/_}{\.{\char'174=:} primitive@>
  18272. primitive("|=:>",lig_kern_token,6);
  18273. @!@:=:/>_}{\.{\char'174=:>} primitive@>
  18274. primitive("|=:|",lig_kern_token,3);
  18275. @!@:=:/_}{\.{\char'174=:\char'174} primitive@>
  18276. primitive("|=:|>",lig_kern_token,7);
  18277. @!@:=:/>_}{\.{\char'174=:\char'174>} primitive@>
  18278. primitive("|=:|>>",lig_kern_token,11);
  18279. @!@:=:/>_}{\.{\char'174=:\char'174>>} primitive@>
  18280. primitive("kern",lig_kern_token,128);
  18281. @!@:kern_}{\&{kern} primitive@>
  18282. @ @<Cases of |print_cmd...@>=
  18283. lig_kern_token: case m of
  18284. 0:print("=:");
  18285. 1:print("=:|");
  18286. 2:print("|=:");
  18287. 3:print("|=:|");
  18288. 5:print("=:|>");
  18289. 6:print("|=:>");
  18290. 7:print("|=:|>");
  18291. 11:print("|=:|>>");
  18292. othercases print("kern")
  18293. endcases;
  18294. @ Local labels are implemented by maintaining the |skip_table| array,
  18295. where |skip_table[c]| is either |undefined_label| or the address of the
  18296. most recent lig/kern instruction that skips to local label~|c|. In the
  18297. latter case, the |skip_byte| in that instruction will (temporarily)
  18298. be zero if there were no prior skips to this label, or it will be the
  18299. distance to the prior skip.
  18300. We may need to cancel skips that span more than 127 lig/kern steps.
  18301. @d cancel_skips(#)==ll:=#;
  18302.   repeat lll:=qo(skip_byte(ll)); skip_byte(ll):=stop_flag; ll:=ll-lll;
  18303.   until lll=0
  18304. @d skip_error(#)==begin print_err("Too far to skip");
  18305. @.Too far to skip@>
  18306.   help1("At most 127 lig/kern steps can separate skipto1 from 1::.");
  18307.   error; cancel_skips(#);
  18308.   end
  18309. @<Process a |skip_to| command and |goto done|@>=
  18310. begin c:=get_code;
  18311. if nl-skip_table[c]>128 then {|skip_table[c]<<nl<=undefined_label|}
  18312.   begin skip_error(skip_table[c]); skip_table[c]:=undefined_label;
  18313.   end;
  18314. if skip_table[c]=undefined_label then skip_byte(nl-1):=qi(0)
  18315. else skip_byte(nl-1):=qi(nl-skip_table[c]-1);
  18316. skip_table[c]:=nl-1; goto done;
  18317. @ @<Record a label in a lig/kern subprogram and |goto continue|@>=
  18318. begin if cur_cmd=colon then
  18319.   if c=256 then bch_label:=nl
  18320.   else set_tag(c,lig_tag,nl)
  18321. else if skip_table[c]<undefined_label then
  18322.   begin ll:=skip_table[c]; skip_table[c]:=undefined_label;
  18323.   repeat lll:=qo(skip_byte(ll));
  18324.   if nl-ll>128 then
  18325.     begin skip_error(ll); goto continue;
  18326.     end;
  18327.   skip_byte(ll):=qi(nl-ll-1); ll:=ll-lll;
  18328.   until lll=0;
  18329.   end;
  18330. goto continue;
  18331. @ @<Compile a ligature/kern...@>=
  18332. begin next_char(nl):=qi(c); skip_byte(nl):=qi(0);
  18333. if cur_mod<128 then {ligature op}
  18334.   begin op_byte(nl):=qi(cur_mod); rem_byte(nl):=qi(get_code);
  18335.   end
  18336. else  begin get_x_next; scan_expression;
  18337.   if cur_type<>known then
  18338.     begin exp_err("Improper kern");
  18339. @.Improper kern@>
  18340.     help2("The amount of kern should be a known numeric value.")@/
  18341.       ("I'm zeroing this one. Proceed, with fingers crossed.");
  18342.     put_get_flush_error(0);
  18343.     end;
  18344.   kern[nk]:=cur_exp;
  18345.   k:=0;@+while kern[k]<>cur_exp do incr(k);
  18346.   if k=nk then
  18347.     begin if nk=max_kerns then overflow("kern",max_kerns);
  18348. @:METAFONT capacity exceeded kern}{\quad kern@>
  18349.     incr(nk);
  18350.     end;
  18351.   op_byte(nl):=kern_flag+(k div 256);
  18352.   rem_byte(nl):=qi((k mod 256));
  18353.   end;
  18354. lk_started:=true;
  18355. @ @d missing_extensible_punctuation(#)==
  18356.   begin missing_err(#);
  18357. @.Missing `\char`\#'@>
  18358.   help1("I'm processing `extensible c: t,m,b,r'."); back_error;
  18359.   end
  18360. @<Define an extensible recipe@>=
  18361. begin if ne=256 then overflow("extensible",256);
  18362. @:METAFONT capacity exceeded extensible}{\quad extensible@>
  18363. c:=get_code; set_tag(c,ext_tag,ne);
  18364. if cur_cmd<>colon then missing_extensible_punctuation(":");
  18365. ext_top(ne):=qi(get_code);
  18366. if cur_cmd<>comma then missing_extensible_punctuation(",");
  18367. ext_mid(ne):=qi(get_code);
  18368. if cur_cmd<>comma then missing_extensible_punctuation(",");
  18369. ext_bot(ne):=qi(get_code);
  18370. if cur_cmd<>comma then missing_extensible_punctuation(",");
  18371. ext_rep(ne):=qi(get_code);
  18372. incr(ne);
  18373. @ @<Store a list of header bytes@>=
  18374. repeat if j>header_size then overflow("headerbyte",header_size);
  18375. @:METAFONT capacity exceeded headerbyte}{\quad headerbyte@>
  18376. header_byte[j]:=get_code; incr(j);
  18377. until cur_cmd<>comma
  18378. @ @<Store a list of font dimensions@>=
  18379. repeat if j>max_font_dimen then overflow("fontdimen",max_font_dimen);
  18380. @:METAFONT capacity exceeded fontdimen}{\quad fontdimen@>
  18381. while j>np do
  18382.   begin incr(np); param[np]:=0;
  18383.   end;
  18384. get_x_next; scan_expression;
  18385. if cur_type<>known then
  18386.   begin exp_err("Improper font parameter");
  18387. @.Improper font parameter@>
  18388.   help1("I'm zeroing this one. Proceed, with fingers crossed.");
  18389.   put_get_flush_error(0);
  18390.   end;
  18391. param[j]:=cur_exp; incr(j);
  18392. until cur_cmd<>comma
  18393. @ OK: We've stored all the data that is needed for the \.{TFM} file.
  18394. All that remains is to output it in the correct format.
  18395. An interesting problem needs to be solved in this connection, because
  18396. the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths,
  18397. and 64~italic corrections. If the data has more distinct values than
  18398. this, we want to meet the necessary restrictions by perturbing the
  18399. given values as little as possible.
  18400. \MF\ solves this problem in two steps. First the values of a given
  18401. kind (widths, heights, depths, or italic corrections) are sorted;
  18402. then the list of sorted values is perturbed, if necessary.
  18403. The sorting operation is facilitated by having a special node of
  18404. essentially infinite |value| at the end of the current list.
  18405. @<Initialize table entries...@>=
  18406. value(inf_val):=fraction_four;
  18407. @ Straight linear insertion is good enough for sorting, since the lists
  18408. are usually not terribly long. As we work on the data, the current list
  18409. will start at |link(temp_head)| and end at |inf_val|; the nodes in this
  18410. list will be in increasing order of their |value| fields.
  18411. Given such a list, the |sort_in| function takes a value and returns a pointer
  18412. to where that value can be found in the list. The value is inserted in
  18413. the proper place, if necessary.
  18414. At the time we need to do these operations, most of \MF's work has been
  18415. completed, so we will have plenty of memory to play with. The value nodes
  18416. that are allocated for sorting will never be returned to free storage.
  18417. @d clear_the_list==link(temp_head):=inf_val
  18418. @p function sort_in(@!v:scaled):pointer;
  18419. label found;
  18420. var @!p,@!q,@!r:pointer; {list manipulation registers}
  18421. begin p:=temp_head;
  18422. loop@+  begin q:=link(p);
  18423.   if v<=value(q) then goto found;
  18424.   p:=q;
  18425.   end;
  18426. found: if v<value(q) then
  18427.   begin r:=get_node(value_node_size); value(r):=v; link(r):=q; link(p):=r;
  18428.   end;
  18429. sort_in:=link(p);
  18430. @ Now we come to the interesting part, where we reduce the list if necessary
  18431. until it has the required size. The |min_cover| routine is basic to this
  18432. process; it computes the minimum number~|m| such that the values of the
  18433. current sorted list can be covered by |m|~intervals of width~|d|. It
  18434. also sets the global value |perturbation| to the smallest value $d'>d$
  18435. such that the covering found by this algorithm would be different.
  18436. In particular, |min_cover(0)| returns the number of distinct values in the
  18437. current list and sets |perturbation| to the minimum distance between
  18438. adjacent values.
  18439. @p function min_cover(@!d:scaled):integer;
  18440. var @!p:pointer; {runs through the current list}
  18441. @!l:scaled; {the least element covered by the current interval}
  18442. @!m:integer; {lower bound on the size of the minimum cover}
  18443. begin m:=0; p:=link(temp_head); perturbation:=el_gordo;
  18444. while p<>inf_val do
  18445.   begin incr(m); l:=value(p);
  18446.   repeat p:=link(p);
  18447.   until value(p)>l+d;
  18448.   if value(p)-l<perturbation then perturbation:=value(p)-l;
  18449.   end;
  18450. min_cover:=m;
  18451. @ @<Glob...@>=
  18452. @!perturbation:scaled; {quantity related to \.{TFM} rounding}
  18453. @!excess:integer; {the list is this much too long}
  18454. @ The smallest |d| such that a given list can be covered with |m| intervals
  18455. is determined by the |threshold| routine, which is sort of an inverse
  18456. to |min_cover|. The idea is to increase the interval size rapidly until
  18457. finding the range, then to go sequentially until the exact borderline has
  18458. been discovered.
  18459. @p function threshold(@!m:integer):scaled;
  18460. var @!d:scaled; {lower bound on the smallest interval size}
  18461. begin excess:=min_cover(0)-m;
  18462. if excess<=0 then threshold:=0
  18463. else  begin repeat d:=perturbation;
  18464.   until min_cover(d+d)<=m;
  18465.   while min_cover(d)>m do d:=perturbation;
  18466.   threshold:=d;
  18467.   end;
  18468. @ The |skimp| procedure reduces the current list to at most |m| entries,
  18469. by changing values if necessary. It also sets |info(p):=k| if |value(p)|
  18470. is the |k|th distinct value on the resulting list, and it sets
  18471. |perturbation| to the maximum amount by which a |value| field has
  18472. been changed. The size of the resulting list is returned as the
  18473. value of |skimp|.
  18474. @p function skimp(@!m:integer):integer;
  18475. var @!d:scaled; {the size of intervals being coalesced}
  18476. @!p,@!q,@!r:pointer; {list manipulation registers}
  18477. @!l:scaled; {the least value in the current interval}
  18478. @!v:scaled; {a compromise value}
  18479. begin d:=threshold(m); perturbation:=0;
  18480. q:=temp_head; m:=0; p:=link(temp_head);
  18481. while p<>inf_val do
  18482.   begin incr(m); l:=value(p); info(p):=m;
  18483.   if value(link(p))<=l+d then
  18484.     @<Replace an interval of values by its midpoint@>;
  18485.   q:=p; p:=link(p);
  18486.   end;
  18487. skimp:=m;
  18488. @ @<Replace an interval...@>=
  18489. begin repeat p:=link(p); info(p):=m;
  18490. decr(excess);@+if excess=0 then d:=0;
  18491. until value(link(p))>l+d;
  18492. v:=l+half(value(p)-l);
  18493. if value(p)-v>perturbation then perturbation:=value(p)-v;
  18494. r:=q;
  18495. repeat r:=link(r); value(r):=v;
  18496. until r=p;
  18497. link(q):=p; {remove duplicate values from the current list}
  18498. @ A warning message is issued whenever something is perturbed by
  18499. more than 1/16\thinspace pt.
  18500. @p procedure tfm_warning(@!m:small_number);
  18501. begin print_nl("(some "); print(int_name[m]);
  18502. @.some charwds...@>
  18503. @.some chardps...@>
  18504. @.some charhts...@>
  18505. @.some charics...@>
  18506. print(" values had to be adjusted by as much as ");
  18507. print_scaled(perturbation); print("pt)");
  18508. @ Here's an example of how we use these routines.
  18509. The width data needs to be perturbed only if there are 256 distinct
  18510. widths, but \MF\ must check for this case even though it is
  18511. highly unusual.
  18512. An integer variable |k| will be defined when we use this code.
  18513. The |dimen_head| array will contain pointers to the sorted
  18514. lists of dimensions.
  18515. @<Massage the \.{TFM} widths@>=
  18516. clear_the_list;
  18517. for k:=bc to ec do if char_exists[k] then
  18518.   tfm_width[k]:=sort_in(tfm_width[k]);
  18519. nw:=skimp(255)+1; dimen_head[1]:=link(temp_head);
  18520. if perturbation>=@'10000 then tfm_warning(char_wd)
  18521. @ @<Glob...@>=
  18522. @!dimen_head:array[1..4] of pointer; {lists of \.{TFM} dimensions}
  18523. @ Heights, depths, and italic corrections are different from widths
  18524. not only because their list length is more severely restricted, but
  18525. also because zero values do not need to be put into the lists.
  18526. @<Massage the \.{TFM} heights, depths, and italic corrections@>=
  18527. clear_the_list;
  18528. for k:=bc to ec do if char_exists[k] then
  18529.   if tfm_height[k]=0 then tfm_height[k]:=zero_val
  18530.   else tfm_height[k]:=sort_in(tfm_height[k]);
  18531. nh:=skimp(15)+1; dimen_head[2]:=link(temp_head);
  18532. if perturbation>=@'10000 then tfm_warning(char_ht);
  18533. clear_the_list;
  18534. for k:=bc to ec do if char_exists[k] then
  18535.   if tfm_depth[k]=0 then tfm_depth[k]:=zero_val
  18536.   else tfm_depth[k]:=sort_in(tfm_depth[k]);
  18537. nd:=skimp(15)+1; dimen_head[3]:=link(temp_head);
  18538. if perturbation>=@'10000 then tfm_warning(char_dp);
  18539. clear_the_list;
  18540. for k:=bc to ec do if char_exists[k] then
  18541.   if tfm_ital_corr[k]=0 then tfm_ital_corr[k]:=zero_val
  18542.   else tfm_ital_corr[k]:=sort_in(tfm_ital_corr[k]);
  18543. ni:=skimp(63)+1; dimen_head[4]:=link(temp_head);
  18544. if perturbation>=@'10000 then tfm_warning(char_ic)
  18545. @ @<Initialize table entries...@>=
  18546. value(zero_val):=0; info(zero_val):=0;
  18547. @ Bytes 5--8 of the header are set to the design size, unless the user has
  18548. some crazy reason for specifying them differently.
  18549. Error messages are not allowed at the time this procedure is called,
  18550. so a warning is printed instead.
  18551. The value of |max_tfm_dimen| is calculated so that
  18552. $$\hbox{|make_scaled(16*max_tfm_dimen,internal[design_size])|}
  18553.  < \\{three\_bytes}.$$
  18554. @d three_bytes==@'100000000 {$2^{24}$}
  18555. @p procedure fix_design_size;
  18556. var @!d:scaled; {the design size}
  18557. begin d:=internal[design_size];
  18558. if (d<unity)or(d>=fraction_half) then
  18559.   begin if d<>0 then
  18560.     print_nl("(illegal design size has been changed to 128pt)");
  18561. @.illegal design size...@>
  18562.   d:=@'40000000; internal[design_size]:=d;
  18563.   end;
  18564. if header_byte[5]<0 then if header_byte[6]<0 then
  18565.   if header_byte[7]<0 then if header_byte[8]<0 then
  18566.   begin header_byte[5]:=d div @'4000000;
  18567.   header_byte[6]:=(d div 4096) mod 256;
  18568.   header_byte[7]:=(d div 16) mod 256;
  18569.   header_byte[8]:=(d mod 16)*16;
  18570.   end;
  18571. max_tfm_dimen:=16*internal[design_size]-internal[design_size] div @'10000000;
  18572. if max_tfm_dimen>=fraction_half then max_tfm_dimen:=fraction_half-1;
  18573. @ The |dimen_out| procedure computes a |fix_word| relative to the
  18574. design size. If the data was out of range, it is corrected and the
  18575. global variable |tfm_changed| is increased by~one.
  18576. @p function dimen_out(@!x:scaled):integer;
  18577. begin if abs(x)>max_tfm_dimen then
  18578.   begin incr(tfm_changed);
  18579.   if x>0 then x:=three_bytes-1@+else x:=1-three_bytes;
  18580.   end
  18581. else x:=make_scaled(x*16,internal[design_size]);
  18582. dimen_out:=x;
  18583. @ @<Glob...@>=
  18584. @!max_tfm_dimen:scaled; {bound on widths, heights, kerns, etc.}
  18585. @!tfm_changed:integer; {the number of data entries that were out of bounds}
  18586. @ If the user has not specified any of the first four header bytes,
  18587. the |fix_check_sum| procedure replaces them by a ``check sum'' computed
  18588. from the |tfm_width| data relative to the design size.
  18589. @^check sum@>
  18590. @p procedure fix_check_sum;
  18591. label exit;
  18592. var @!k:eight_bits; {runs through character codes}
  18593. @!b1,@!b2,@!b3,@!b4:eight_bits; {bytes of the check sum}
  18594. @!x:integer; {hash value used in check sum computation}
  18595. begin if header_byte[1]<0 then if header_byte[2]<0 then
  18596.   if header_byte[3]<0 then if header_byte[4]<0 then
  18597.   begin @<Compute a check sum in |(b1,b2,b3,b4)|@>;
  18598.   header_byte[1]:=b1; header_byte[2]:=b2;
  18599.   header_byte[3]:=b3; header_byte[4]:=b4; return;
  18600.   end;
  18601. for k:=1 to 4 do if header_byte[k]<0 then header_byte[k]:=0;
  18602. exit:end;
  18603. @ @<Compute a check sum in |(b1,b2,b3,b4)|@>=
  18604. b1:=bc; b2:=ec; b3:=bc; b4:=ec; tfm_changed:=0;
  18605. for k:=bc to ec do if char_exists[k] then
  18606.   begin x:=dimen_out(value(tfm_width[k]))+(k+4)*@'20000000; {this is positive}
  18607.   b1:=(b1+b1+x) mod 255;
  18608.   b2:=(b2+b2+x) mod 253;
  18609.   b3:=(b3+b3+x) mod 251;
  18610.   b4:=(b4+b4+x) mod 247;
  18611.   end
  18612. @ Finally we're ready to actually write the \.{TFM} information.
  18613. Here are some utility routines for this purpose.
  18614. @d tfm_out(#)==write(tfm_file,#) {output one byte to |tfm_file|}
  18615. @p procedure tfm_two(@!x:integer); {output two bytes to |tfm_file|}
  18616. begin tfm_out(x div 256); tfm_out(x mod 256);
  18617. procedure tfm_four(@!x:integer); {output four bytes to |tfm_file|}
  18618. begin if x>=0 then tfm_out(x div three_bytes)
  18619. else  begin x:=x+@'10000000000; {use two's complement for negative values}
  18620.   x:=x+@'10000000000;
  18621.   tfm_out((x div three_bytes) + 128);
  18622.   end;
  18623. x:=x mod three_bytes; tfm_out(x div unity);
  18624. x:=x mod unity; tfm_out(x div @'400);
  18625. tfm_out(x mod @'400);
  18626. procedure tfm_qqqq(@!x:four_quarters); {output four quarterwords to |tfm_file|}
  18627. begin tfm_out(qo(x.b0)); tfm_out(qo(x.b1)); tfm_out(qo(x.b2));
  18628. tfm_out(qo(x.b3));
  18629. @ @<Finish the \.{TFM} file@>=
  18630. if job_name=0 then open_log_file;
  18631. pack_job_name(".tfm");
  18632. while not b_open_out(tfm_file) do
  18633.   prompt_file_name("file name for font metrics",".tfm");
  18634. metric_file_name:=b_make_name_string(tfm_file);
  18635. @<Output the subfile sizes and header bytes@>;
  18636. @<Output the character information bytes, then
  18637.   output the dimensions themselves@>;
  18638. @<Output the ligature/kern program@>;
  18639. @<Output the extensible character recipes and the font metric parameters@>;
  18640. @!stat if internal[tracing_stats]>0 then
  18641.   @<Log the subfile sizes of the \.{TFM} file@>;@;@+tats@/
  18642. print_nl("Font metrics written on "); slow_print(metric_file_name);
  18643. print_char(".");
  18644. @.Font metrics written...@>
  18645. b_close(tfm_file)
  18646. @ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use
  18647. this code.
  18648. @<Output the subfile sizes and header bytes@>=
  18649. k:=header_size;
  18650. while header_byte[k]<0 do decr(k);
  18651. lh:=(k+3) div 4; {this is the number of header words}
  18652. if bc>ec then bc:=1; {if there are no characters, |ec=0| and |bc=1|}
  18653. @<Compute the ligature/kern program offset and implant the
  18654.   left boundary label@>;
  18655. tfm_two(6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+lk_offset+nk+ne+np);
  18656.   {this is the total number of file words that will be output}
  18657. tfm_two(lh); tfm_two(bc); tfm_two(ec); tfm_two(nw); tfm_two(nh);
  18658. tfm_two(nd); tfm_two(ni); tfm_two(nl+lk_offset); tfm_two(nk); tfm_two(ne);
  18659. tfm_two(np);
  18660. for k:=1 to 4*lh do
  18661.   begin if header_byte[k]<0 then header_byte[k]:=0;
  18662.   tfm_out(header_byte[k]);
  18663.   end
  18664. @ @<Output the character information bytes...@>=
  18665. for k:=bc to ec do
  18666.   if not char_exists[k] then tfm_four(0)
  18667.   else  begin tfm_out(info(tfm_width[k])); {the width index}
  18668.     tfm_out((info(tfm_height[k]))*16+info(tfm_depth[k]));
  18669.     tfm_out((info(tfm_ital_corr[k]))*4+char_tag[k]);
  18670.     tfm_out(char_remainder[k]);
  18671.     end;
  18672. tfm_changed:=0;
  18673. for k:=1 to 4 do
  18674.   begin tfm_four(0); p:=dimen_head[k];
  18675.   while p<>inf_val do
  18676.     begin tfm_four(dimen_out(value(p))); p:=link(p);
  18677.     end;
  18678.   end
  18679. @ We need to output special instructions at the beginning of the
  18680. |lig_kern| array in order to specify the right boundary character
  18681. and/or to handle starting addresses that exceed 255. The |label_loc|
  18682. and |label_char| arrays have been set up to record all the
  18683. starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots
  18684. \le|label_loc|[|label_ptr]|$.
  18685. @<Compute the ligature/kern program offset...@>=
  18686. bchar:=round_unscaled(internal[boundary_char]);
  18687. if(bchar<0)or(bchar>255)then
  18688.   begin bchar:=-1; lk_started:=false; lk_offset:=0;@+end
  18689. else begin lk_started:=true; lk_offset:=1;@+end;
  18690. @<Find the minimum |lk_offset| and adjust all remainders@>;
  18691. if bch_label<undefined_label then
  18692.   begin skip_byte(nl):=qi(255); next_char(nl):=qi(0);
  18693.   op_byte(nl):=qi(((bch_label+lk_offset)div 256));
  18694.   rem_byte(nl):=qi(((bch_label+lk_offset)mod 256));
  18695.   incr(nl); {possibly |nl=lig_table_size+1|}
  18696.   end
  18697. @ @<Find the minimum |lk_offset|...@>=
  18698. k:=label_ptr; {pointer to the largest unallocated label}
  18699. if label_loc[k]+lk_offset>255 then
  18700.   begin lk_offset:=0; lk_started:=false; {location 0 can do double duty}
  18701.   repeat char_remainder[label_char[k]]:=lk_offset;
  18702.   while label_loc[k-1]=label_loc[k] do
  18703.     begin decr(k); char_remainder[label_char[k]]:=lk_offset;
  18704.     end;
  18705.   incr(lk_offset); decr(k);
  18706.   until lk_offset+label_loc[k]<256;
  18707.     {N.B.: |lk_offset=256| satisfies this when |k=0|}
  18708.   end;
  18709. if lk_offset>0 then
  18710.   while k>0 do
  18711.     begin char_remainder[label_char[k]]
  18712.      :=char_remainder[label_char[k]]+lk_offset;
  18713.     decr(k);
  18714.     end
  18715. @ @<Output the ligature/kern program@>=
  18716. for k:=0 to 255 do if skip_table[k]<undefined_label then
  18717.   begin print_nl("(local label "); print_int(k); print(":: was missing)");
  18718. @.local label l:: was missing@>
  18719.   cancel_skips(skip_table[k]);
  18720.   end;
  18721. if lk_started then {|lk_offset=1| for the special |bchar|}
  18722.   begin tfm_out(255); tfm_out(bchar); tfm_two(0);
  18723.   end
  18724. else for k:=1 to lk_offset do {output the redirection specs}
  18725.   begin ll:=label_loc[label_ptr];
  18726.   if bchar<0 then
  18727.     begin tfm_out(254); tfm_out(0);
  18728.     end
  18729.   else begin tfm_out(255); tfm_out(bchar);
  18730.     end;
  18731.   tfm_two(ll+lk_offset);
  18732.   repeat decr(label_ptr);
  18733.   until label_loc[label_ptr]<ll;
  18734.   end;
  18735. for k:=0 to nl-1 do tfm_qqqq(lig_kern[k]);
  18736. for k:=0 to nk-1 do tfm_four(dimen_out(kern[k]))
  18737. @ @<Output the extensible character recipes...@>=
  18738. for k:=0 to ne-1 do tfm_qqqq(exten[k]);
  18739. for k:=1 to np do
  18740.   if k=1 then
  18741.     if abs(param[1])<fraction_half then tfm_four(param[1]*16)
  18742.     else  begin incr(tfm_changed);
  18743.       if param[1]>0 then tfm_four(el_gordo)
  18744.       else tfm_four(-el_gordo);
  18745.       end
  18746.   else tfm_four(dimen_out(param[k]));
  18747. if tfm_changed>0 then
  18748.   begin if tfm_changed=1 then print_nl("(a font metric dimension")
  18749. @.a font metric dimension...@>
  18750.   else  begin print_nl("("); print_int(tfm_changed);
  18751. @.font metric dimensions...@>
  18752.     print(" font metric dimensions");
  18753.     end;
  18754.   print(" had to be decreased)");
  18755.   end
  18756. @ @<Log the subfile sizes of the \.{TFM} file@>=
  18757. begin wlog_ln(' ');
  18758. if bch_label<undefined_label then decr(nl);
  18759. wlog_ln('(You used ',nw:1,'w,',@| nh:1,'h,',@| nd:1,'d,',@| ni:1,'i,',@|
  18760.  nl:1,'l,',@| nk:1,'k,',@| ne:1,'e,',@|
  18761.  np:1,'p metric file positions');
  18762. wlog_ln('  out of ',@| '256w,16h,16d,64i,',@|
  18763.  lig_table_size:1,'l,',max_kerns:1,'k,256e,',@|
  18764.  max_font_dimen:1,'p)');
  18765. @* \[46] Generic font file format.
  18766. The most important output produced by a typical run of \MF\ is the
  18767. ``generic font'' (\.{GF}) file that specifies the bit patterns of the
  18768. characters that have been drawn. The term {\sl generic\/} indicates that
  18769. this file format doesn't match the conventions of any name-brand manufacturer;
  18770. but it is easy to convert \.{GF} files to the special format required by
  18771. almost all digital phototypesetting equipment. There's a strong analogy
  18772. between the \.{DVI} files written by \TeX\ and the \.{GF} files written
  18773. by \MF; and, in fact, the file formats have a lot in common.
  18774. A \.{GF} file is a stream of 8-bit bytes that may be
  18775. regarded as a series of commands in a machine-like language. The first
  18776. byte of each command is the operation code, and this code is followed by
  18777. zero or more bytes that provide parameters to the command. The parameters
  18778. themselves may consist of several consecutive bytes; for example, the
  18779. `|boc|' (beginning of character) command has six parameters, each of
  18780. which is four bytes long. Parameters are usually regarded as nonnegative
  18781. integers; but four-byte-long parameters can be either positive or
  18782. negative, hence they range in value from $-2^{31}$ to $2^{31}-1$.
  18783. As in \.{TFM} files, numbers that occupy
  18784. more than one byte position appear in BigEndian order,
  18785. and negative numbers appear in two's complement notation.
  18786. A \.{GF} file consists of a ``preamble,'' followed by a sequence of one or
  18787. more ``characters,'' followed by a ``postamble.'' The preamble is simply a
  18788. |pre| command, with its parameters that introduce the file; this must come
  18789. first.  Each ``character'' consists of a |boc| command, followed by any
  18790. number of other commands that specify ``black'' pixels,
  18791. followed by an |eoc| command. The characters appear in the order that \MF\
  18792. generated them. If we ignore no-op commands (which are allowed between any
  18793. two commands in the file), each |eoc| command is immediately followed by a
  18794. |boc| command, or by a |post| command; in the latter case, there are no
  18795. more characters in the file, and the remaining bytes form the postamble.
  18796. Further details about the postamble will be explained later.
  18797. Some parameters in \.{GF} commands are ``pointers.'' These are four-byte
  18798. quantities that give the location number of some other byte in the file;
  18799. the first file byte is number~0, then comes number~1, and so on.
  18800. @ The \.{GF} format is intended to be both compact and easily interpreted
  18801. by a machine. Compactness is achieved by making most of the information
  18802. relative instead of absolute. When a \.{GF}-reading program reads the
  18803. commands for a character, it keeps track of two quantities: (a)~the current
  18804. column number,~|m|; and (b)~the current row number,~|n|.  These are 32-bit
  18805. signed integers, although most actual font formats produced from \.{GF}
  18806. files will need to curtail this vast range because of practical
  18807. limitations. (\MF\ output will never allow $\vert m\vert$ or $\vert
  18808. n\vert$ to get extremely large, but the \.{GF} format tries to be more general.)
  18809. How do \.{GF}'s row and column numbers correspond to the conventions
  18810. of \TeX\ and \MF? Well, the ``reference point'' of a character, in \TeX's
  18811. view, is considered to be at the lower left corner of the pixel in row~0
  18812. and column~0. This point is the intersection of the baseline with the left
  18813. edge of the type; it corresponds to location $(0,0)$ in \MF\ programs.
  18814. Thus the pixel in \.{GF} row~0 and column~0 is \MF's unit square, comprising the
  18815. region of the plane whose coordinates both lie between 0 and~1. The
  18816. pixel in \.{GF} row~|n| and column~|m| consists of the points whose \MF\
  18817. coordinates |(x,y)| satisfy |m<=x<=m+1| and |n<=y<=n+1|.  Negative values of
  18818. |m| and~|x| correspond to columns of pixels {\sl left\/} of the reference
  18819. point; negative values of |n| and~|y| correspond to rows of pixels {\sl
  18820. below\/} the baseline.
  18821. Besides |m| and |n|, there's also a third aspect of the current
  18822. state, namely the @!|paint_switch|, which is always either |black| or
  18823. |white|. Each \\{paint} command advances |m| by a specified amount~|d|,
  18824. and blackens the intervening pixels if |paint_switch=black|; then
  18825. the |paint_switch| changes to the opposite state. \.{GF}'s commands are
  18826. designed so that |m| will never decrease within a row, and |n| will never
  18827. increase within a character; hence there is no way to whiten a pixel that
  18828. has been blackened.
  18829. @ Here is a list of all the commands that may appear in a \.{GF} file. Each
  18830. command is specified by its symbolic name (e.g., |boc|), its opcode byte
  18831. (e.g., 67), and its parameters (if any). The parameters are followed
  18832. by a bracketed number telling how many bytes they occupy; for example,
  18833. `|d[2]|' means that parameter |d| is two bytes long.
  18834. \yskip\hang|paint_0| 0. This is a \\{paint} command with |d=0|; it does
  18835. nothing but change the |paint_switch| from \\{black} to \\{white} or vice~versa.
  18836. \yskip\hang\\{paint\_1} through \\{paint\_63} (opcodes 1 to 63).
  18837. These are \\{paint} commands with |d=1| to~63, defined as follows: If
  18838. |paint_switch=black|, blacken |d|~pixels of the current row~|n|,
  18839. in columns |m| through |m+d-1| inclusive. Then, in any case,
  18840. complement the |paint_switch| and advance |m| by~|d|.
  18841. \yskip\hang|paint1| 64 |d[1]|. This is a \\{paint} command with a specified
  18842. value of~|d|; \MF\ uses it to paint when |64<=d<256|.
  18843. \yskip\hang|@!paint2| 65 |d[2]|. Same as |paint1|, but |d|~can be as high
  18844. as~65535.
  18845. \yskip\hang|@!paint3| 66 |d[3]|. Same as |paint1|, but |d|~can be as high
  18846. as $2^{24}-1$. \MF\ never needs this command, and it is hard to imagine
  18847. anybody making practical use of it; surely a more compact encoding will be
  18848. desirable when characters can be this large. But the command is there,
  18849. anyway, just in case.
  18850. \yskip\hang|boc| 67 |c[4]| |p[4]| |min_m[4]| |max_m[4]| |min_n[4]|
  18851. |max_n[4]|. Beginning of a character:  Here |c| is the character code, and
  18852. |p| points to the previous character beginning (if any) for characters having
  18853. this code number modulo 256.  (The pointer |p| is |-1| if there was no
  18854. prior character with an equivalent code.) The values of registers |m| and |n|
  18855. defined by the instructions that follow for this character must
  18856. satisfy |min_m<=m<=max_m| and |min_n<=n<=max_n|.  (The values of |max_m| and
  18857. |min_n| need not be the tightest bounds possible.)  When a \.{GF}-reading
  18858. program sees a |boc|, it can use |min_m|, |max_m|, |min_n|, and |max_n| to
  18859. initialize the bounds of an array. Then it sets |m:=min_m|, |n:=max_n|, and
  18860. |paint_switch:=white|.
  18861. \yskip\hang|boc1| 68 |c[1]| |@!del_m[1]| |max_m[1]| |@!del_n[1]| |max_n[1]|.
  18862. Same as |boc|, but |p| is assumed to be~$-1$; also |del_m=max_m-min_m|
  18863. and |del_n=max_n-min_n| are given instead of |min_m| and |min_n|.
  18864. The one-byte parameters must be between 0 and 255, inclusive.
  18865. \ (This abbreviated |boc| saves 19~bytes per character, in common cases.)
  18866. \yskip\hang|eoc| 69. End of character: All pixels blackened so far
  18867. constitute the pattern for this character. In particular, a completely
  18868. blank character might have |eoc| immediately following |boc|.
  18869. \yskip\hang|skip0| 70. Decrease |n| by 1 and set |m:=min_m|,
  18870. |paint_switch:=white|. \ (This finishes one row and begins another,
  18871. ready to whiten the leftmost pixel in the new row.)
  18872. \yskip\hang|skip1| 71 |d[1]|. Decrease |n| by |d+1|, set |m:=min_m|, and set
  18873. |paint_switch:=white|. This is a way to produce |d| all-white rows.
  18874. \yskip\hang|@!skip2| 72 |d[2]|. Same as |skip1|, but |d| can be as large
  18875. as 65535.
  18876. \yskip\hang|@!skip3| 73 |d[3]|. Same as |skip1|, but |d| can be as large
  18877. as $2^{24}-1$. \MF\ obviously never needs this command.
  18878. \yskip\hang|new_row_0| 74. Decrease |n| by 1 and set |m:=min_m|,
  18879. |paint_switch:=black|. \ (This finishes one row and begins another,
  18880. ready to {\sl blacken\/} the leftmost pixel in the new row.)
  18881. \yskip\hang|@!new_row_1| through |@!new_row_164| (opcodes 75 to 238). Same as
  18882. |new_row_0|, but with |m:=min_m+1| through |min_m+164|, respectively.
  18883. \yskip\hang|xxx1| 239 |k[1]| |x[k]|. This command is undefined in
  18884. general; it functions as a $(k+2)$-byte |no_op| unless special \.{GF}-reading
  18885. programs are being used. \MF\ generates \\{xxx} commands when encountering
  18886. a \&{special} string; this occurs in the \.{GF} file only between
  18887. characters, after the preamble, and before the postamble. However,
  18888. \\{xxx} commands might appear within characters,
  18889. in \.{GF} files generated by other
  18890. processors. It is recommended that |x| be a string having the form of a
  18891. keyword followed by possible parameters relevant to that keyword.
  18892. \yskip\hang|@!xxx2| 240 |k[2]| |x[k]|. Like |xxx1|, but |0<=k<65536|.
  18893. \yskip\hang|xxx3| 241 |k[3]| |x[k]|. Like |xxx1|, but |0<=k<@t$2^{24}$@>|.
  18894. \MF\ uses this when sending a \&{special} string whose length exceeds~255.
  18895. \yskip\hang|@!xxx4| 242 |k[4]| |x[k]|. Like |xxx1|, but |k| can be
  18896. ridiculously large; |k| mustn't be negative.
  18897. \yskip\hang|yyy| 243 |y[4]|. This command is undefined in general;
  18898. it functions as a 5-byte |no_op| unless special \.{GF}-reading programs
  18899. are being used. \MF\ puts |scaled| numbers into |yyy|'s, as a
  18900. result of \&{numspecial} commands; the intent is to provide numeric
  18901. parameters to \\{xxx} commands that immediately precede.
  18902. \yskip\hang|@!no_op| 244. No operation, do nothing. Any number of |no_op|'s
  18903. may occur between \.{GF} commands, but a |no_op| cannot be inserted between
  18904. a command and its parameters or between two parameters.
  18905. \yskip\hang|char_loc| 245 |c[1]| |dx[4]| |dy[4]| |w[4]| |p[4]|.
  18906. This command will appear only in the postamble, which will be explained shortly.
  18907. \yskip\hang|@!char_loc0| 246 |c[1]| |@!dm[1]| |w[4]| |p[4]|.
  18908. Same as |char_loc|, except that |dy| is assumed to be zero, and the value
  18909. of~|dx| is taken to be |65536*dm|, where |0<=dm<256|.
  18910. \yskip\hang|pre| 247 |i[1]| |k[1]| |x[k]|.
  18911. Beginning of the preamble; this must come at the very beginning of the
  18912. file. Parameter |i| is an identifying number for \.{GF} format, currently
  18913. 131. The other information is merely commentary; it is not given
  18914. special interpretation like \\{xxx} commands are. (Note that \\{xxx}
  18915. commands may immediately follow the preamble, before the first |boc|.)
  18916. \yskip\hang|post| 248. Beginning of the postamble, see below.
  18917. \yskip\hang|post_post| 249. Ending of the postamble, see below.
  18918. \yskip\noindent Commands 250--255 are undefined at the present time.
  18919. @d gf_id_byte=131 {identifies the kind of \.{GF} files described here}
  18920. @ \MF\ refers to the following opcodes explicitly.
  18921. @d paint_0=0 {beginning of the \\{paint} commands}
  18922. @d paint1=64 {move right a given number of columns, then
  18923.   black${}\swap{}$white}
  18924. @d boc=67 {beginning of a character}
  18925. @d boc1=68 {short form of |boc|}
  18926. @d eoc=69 {end of a character}
  18927. @d skip0=70 {skip no blank rows}
  18928. @d skip1=71 {skip over blank rows}
  18929. @d new_row_0=74 {move down one row and then right}
  18930. @d max_new_row=164 {the largest \\{new\_row} command is |new_row_164|}
  18931. @d xxx1=239 {for \&{special} strings}
  18932. @d xxx3=241 {for long \&{special} strings}
  18933. @d yyy=243 {for \&{numspecial} numbers}
  18934. @d char_loc=245 {character locators in the postamble}
  18935. @d pre=247 {preamble}
  18936. @d post=248 {postamble beginning}
  18937. @d post_post=249 {postamble ending}
  18938. @ The last character in a \.{GF} file is followed by `|post|'; this command
  18939. introduces the postamble, which summarizes important facts that \MF\ has
  18940. accumulated. The postamble has the form
  18941. $$\vbox{\halign{\hbox{#\hfil}\cr
  18942.   |post| |p[4]| |@!ds[4]| |@!cs[4]| |@!hppp[4]| |@!vppp[4]|
  18943.    |@!min_m[4]| |@!max_m[4]| |@!min_n[4]| |@!max_n[4]|\cr
  18944.   $\langle\,$character locators$\,\rangle$\cr
  18945.   |post_post| |q[4]| |i[1]| 223's$[{\G}4]$\cr}}$$
  18946. Here |p| is a pointer to the byte following the final |eoc| in the file
  18947. (or to the byte following the preamble, if there are no characters);
  18948. it can be used to locate the beginning of \\{xxx} commands
  18949. that might have preceded the postamble. The |ds| and |cs| parameters
  18950. @^design size@> @^check sum@>
  18951. give the design size and check sum, respectively, which are exactly the
  18952. values put into the header of the \.{TFM} file that \MF\ produces (or
  18953. would produce) on this run. Parameters |hppp| and |vppp| are the ratios of
  18954. pixels per point, horizontally and vertically, expressed as |scaled| integers
  18955. (i.e., multiplied by $2^{16}$); they can be used to correlate the font
  18956. with specific device resolutions, magnifications, and ``at sizes.''  Then
  18957. come |min_m|, |max_m|, |min_n|, and |max_n|, which bound the values that
  18958. registers |m| and~|n| assume in all characters in this \.{GF} file.
  18959. (These bounds need not be the best possible; |max_m| and |min_n| may, on the
  18960. other hand, be tighter than the similar bounds in |boc| commands. For
  18961. example, some character may have |min_n=-100| in its |boc|, but it might
  18962. turn out that |n| never gets lower than |-50| in any character; then
  18963. |min_n| can have any value |<=-50|. If there are no characters in the file,
  18964. it's possible to have |min_m>max_m| and/or |min_n>max_n|.)
  18965. @ Character locators are introduced by |char_loc| commands,
  18966. which specify a character residue~|c|, character escapements (|dx,dy|),
  18967. a character width~|w|, and a pointer~|p|
  18968. to the beginning of that character. (If two or more characters have the
  18969. same code~|c| modulo 256, only the last will be indicated; the others can be
  18970. located by following backpointers. Characters whose codes differ by a
  18971. multiple of 256 are assumed to share the same font metric information,
  18972. hence the \.{TFM} file contains only residues of character codes modulo~256.
  18973. This convention is intended for oriental languages, when there are many
  18974. character shapes but few distinct widths.)
  18975. @^oriental characters@>@^Chinese characters@>@^Japanese characters@>
  18976. The character escapements (|dx,dy|) are the values of \MF's \&{chardx}
  18977. and \&{chardy} parameters; they are in units of |scaled| pixels;
  18978. i.e., |dx| is in horizontal pixel units times $2^{16}$, and |dy| is in
  18979. vertical pixel units times $2^{16}$.  This is the intended amount of
  18980. displacement after typesetting the character; for \.{DVI} files, |dy|
  18981. should be zero, but other document file formats allow nonzero vertical
  18982. escapement.
  18983. The character width~|w| duplicates the information in the \.{TFM} file; it
  18984. is a |fix_word| value relative to the design size, and it should be
  18985. independent of magnification.
  18986. The backpointer |p| points to the character's |boc|, or to the first of
  18987. a sequence of consecutive \\{xxx} or |yyy| or |no_op| commands that
  18988. immediately precede the |boc|, if such commands exist; such ``special''
  18989. commands essentially belong to the characters, while the special commands
  18990. after the final character belong to the postamble (i.e., to the font
  18991. as a whole). This convention about |p| applies also to the backpointers
  18992. in |boc| commands, even though it wasn't explained in the description
  18993. of~|boc|. @^backpointers@>
  18994. Pointer |p| might be |-1| if the character exists in the \.{TFM} file
  18995. but not in the \.{GF} file. This unusual situation can arise in \MF\ output
  18996. if the user had |proofing<0| when the character was being shipped out,
  18997. but then made |proofing>=0| in order to get a \.{GF} file.
  18998. @ The last part of the postamble, following the |post_post| byte that
  18999. signifies the end of the character locators, contains |q|, a pointer to the
  19000. |post| command that started the postamble.  An identification byte, |i|,
  19001. comes next; this currently equals~131, as in the preamble.
  19002. The |i| byte is followed by four or more bytes that are all equal to
  19003. the decimal number 223 (i.e., @'337 in octal). \MF\ puts out four to seven of
  19004. these trailing bytes, until the total length of the file is a multiple of
  19005. four bytes, since this works out best on machines that pack four bytes per
  19006. word; but any number of 223's is allowed, as long as there are at least four
  19007. of them. In effect, 223 is a sort of signature that is added at the very end.
  19008. @^Fuchs, David Raymond@>
  19009. This curious way to finish off a \.{GF} file makes it feasible for
  19010. \.{GF}-reading programs to find the postamble first, on most computers,
  19011. even though \MF\ wants to write the postamble last. Most operating
  19012. systems permit random access to individual words or bytes of a file, so
  19013. the \.{GF} reader can start at the end and skip backwards over the 223's
  19014. until finding the identification byte. Then it can back up four bytes, read
  19015. |q|, and move to byte |q| of the file. This byte should, of course,
  19016. contain the value 248 (|post|); now the postamble can be read, so the
  19017. \.{GF} reader can discover all the information needed for individual characters.
  19018. Unfortunately, however, standard \PASCAL\ does not include the ability to
  19019. @^system dependencies@>
  19020. access a random position in a file, or even to determine the length of a file.
  19021. Almost all systems nowadays provide the necessary capabilities, so \.{GF}
  19022. format has been designed to work most efficiently with modern operating systems.
  19023. But if \.{GF} files have to be processed under the restrictions of standard
  19024. \PASCAL, one can simply read them from front to back. This will
  19025. be adequate for most applications. However, the postamble-first approach
  19026. would facilitate a program that merges two \.{GF} files, replacing data
  19027. from one that is overridden by corresponding data in the other.
  19028. @* \[47] Shipping characters out.
  19029. The |ship_out| procedure, to be described below, is given a pointer to
  19030. an edge structure. Its mission is to describe the the positive pixels
  19031. in \.{GF} form, outputting a ``character'' to |gf_file|.
  19032. Several global variables hold information about the font file as a whole:\
  19033. |gf_min_m|, |gf_max_m|, |gf_min_n|, and |gf_max_n| are the minimum and
  19034. maximum \.{GF} coordinates output so far; |gf_prev_ptr| is the byte number
  19035. following the preamble or the last |eoc| command in the output;
  19036. |total_chars| is the total number of characters (i.e., |boc..eoc| segments)
  19037. shipped out.  There's also an array, |char_ptr|, containing the starting
  19038. positions of each character in the file, as required for the postamble. If
  19039. character code~|c| has not yet been output, |char_ptr[c]=-1|.
  19040. @<Glob...@>=
  19041. @!gf_min_m,@!gf_max_m,@!gf_min_n,@!gf_max_n:integer; {bounding rectangle}
  19042. @!gf_prev_ptr:integer; {where the present/next character started/starts}
  19043. @!total_chars:integer; {the number of characters output so far}
  19044. @!char_ptr:array[eight_bits] of integer; {where individual characters started}
  19045. @!gf_dx,@!gf_dy:array[eight_bits] of integer; {device escapements}
  19046. @ @<Set init...@>=
  19047. gf_prev_ptr:=0; total_chars:=0;
  19048. @ The \.{GF} bytes are output to a buffer instead of being sent
  19049. byte-by-byte to |gf_file|, because this tends to save a lot of
  19050. subroutine-call overhead. \MF\ uses the same conventions for |gf_file|
  19051. as \TeX\ uses for its \\{dvi\_file}; hence if system-dependent
  19052. changes are needed, they should probably be the same for both programs.
  19053. The output buffer is divided into two parts of equal size; the bytes found
  19054. in |gf_buf[0..half_buf-1]| constitute the first half, and those in
  19055. |gf_buf[half_buf..gf_buf_size-1]| constitute the second. The global
  19056. variable |gf_ptr| points to the position that will receive the next
  19057. output byte. When |gf_ptr| reaches |gf_limit|, which is always equal
  19058. to one of the two values |half_buf| or |gf_buf_size|, the half buffer that
  19059. is about to be invaded next is sent to the output and |gf_limit| is
  19060. changed to its other value. Thus, there is always at least a half buffer's
  19061. worth of information present, except at the very beginning of the job.
  19062. Bytes of the \.{GF} file are numbered sequentially starting with 0;
  19063. the next byte to be generated will be number |gf_offset+gf_ptr|.
  19064. @<Types...@>=
  19065. @!gf_index=0..gf_buf_size; {an index into the output buffer}
  19066. @ Some systems may find it more efficient to make |gf_buf| a |packed|
  19067. array, since output of four bytes at once may be facilitated.
  19068. @^system dependencies@>
  19069. @<Glob...@>=
  19070. @!gf_buf:array[gf_index] of eight_bits; {buffer for \.{GF} output}
  19071. @!half_buf:gf_index; {half of |gf_buf_size|}
  19072. @!gf_limit:gf_index; {end of the current half buffer}
  19073. @!gf_ptr:gf_index; {the next available buffer address}
  19074. @!gf_offset:integer; {|gf_buf_size| times the number of times the
  19075.   output buffer has been fully emptied}
  19076. @ Initially the buffer is all in one piece; we will output half of it only
  19077. after it first fills up.
  19078. @<Set init...@>=
  19079. half_buf:=gf_buf_size div 2; gf_limit:=gf_buf_size; gf_ptr:=0;
  19080. gf_offset:=0;
  19081. @ The actual output of |gf_buf[a..b]| to |gf_file| is performed by calling
  19082. |write_gf(a,b)|. It is safe to assume that |a| and |b+1| will both be
  19083. multiples of 4 when |write_gf(a,b)| is called; therefore it is possible on
  19084. many machines to use efficient methods to pack four bytes per word and to
  19085. output an array of words with one system call.
  19086. @^system dependencies@>
  19087. @<Declare generic font output procedures@>=
  19088. procedure write_gf(@!a,@!b:gf_index);
  19089. var k:gf_index;
  19090. begin for k:=a to b do write(gf_file,gf_buf[k]);
  19091. @ To put a byte in the buffer without paying the cost of invoking a procedure
  19092. each time, we use the macro |gf_out|.
  19093. @d gf_out(#)==@+begin gf_buf[gf_ptr]:=#; incr(gf_ptr);
  19094.   if gf_ptr=gf_limit then gf_swap;
  19095.   end
  19096. @<Declare generic font output procedures@>=
  19097. procedure gf_swap; {outputs half of the buffer}
  19098. begin if gf_limit=gf_buf_size then
  19099.   begin write_gf(0,half_buf-1); gf_limit:=half_buf;
  19100.   gf_offset:=gf_offset+gf_buf_size; gf_ptr:=0;
  19101.   end
  19102. else  begin write_gf(half_buf,gf_buf_size-1); gf_limit:=gf_buf_size;
  19103.   end;
  19104. @ Here is how we clean out the buffer when \MF\ is all through; |gf_ptr|
  19105. will be a multiple of~4.
  19106. @<Empty the last bytes out of |gf_buf|@>=
  19107. if gf_limit=half_buf then write_gf(half_buf,gf_buf_size-1);
  19108. if gf_ptr>0 then write_gf(0,gf_ptr-1)
  19109. @ The |gf_four| procedure outputs four bytes in two's complement notation,
  19110. without risking arithmetic overflow.
  19111. @<Declare generic font output procedures@>=
  19112. procedure gf_four(@!x:integer);
  19113. begin if x>=0 then gf_out(x div three_bytes)
  19114. else  begin x:=x+@'10000000000;
  19115.   x:=x+@'10000000000;
  19116.   gf_out((x div three_bytes) + 128);
  19117.   end;
  19118. x:=x mod three_bytes; gf_out(x div unity);
  19119. x:=x mod unity; gf_out(x div @'400);
  19120. gf_out(x mod @'400);
  19121. @ Of course, it's even easier to output just two or three bytes.
  19122. @<Declare generic font output procedures@>=
  19123. procedure gf_two(@!x:integer);
  19124. begin gf_out(x div @'400); gf_out(x mod @'400);
  19125. procedure gf_three(@!x:integer);
  19126. begin gf_out(x div unity); gf_out((x mod unity) div @'400);
  19127. gf_out(x mod @'400);
  19128. @ We need a simple routine to generate a \\{paint}
  19129. command of the appropriate type.
  19130. @<Declare generic font output procedures@>=
  19131. procedure gf_paint(@!d:integer); {here |0<=d<65536|}
  19132. begin if d<64 then gf_out(paint_0+d)
  19133. else if d<256 then
  19134.   begin gf_out(paint1); gf_out(d);
  19135.   end
  19136. else  begin gf_out(paint1+1); gf_two(d);
  19137.   end;
  19138. @ And |gf_string| outputs one or two strings. If the first string number
  19139. is nonzero, an \\{xxx} command is generated.
  19140. @<Declare generic font output procedures@>=
  19141. procedure gf_string(@!s,@!t:str_number);
  19142. var @!k:pool_pointer;
  19143. @!l:integer; {length of the strings to output}
  19144. begin if s<>0 then
  19145.   begin l:=length(s);
  19146.   if t<>0 then l:=l+length(t);
  19147.   if l<=255 then
  19148.     begin gf_out(xxx1); gf_out(l);
  19149.     end
  19150.   else  begin gf_out(xxx3); gf_three(l);
  19151.     end;
  19152.   for k:=str_start[s] to str_start[s+1]-1 do gf_out(so(str_pool[k]));
  19153.   end;
  19154. if t<>0 then for k:=str_start[t] to str_start[t+1]-1 do gf_out(so(str_pool[k]));
  19155. @ The choice between |boc| commands is handled by |gf_boc|.
  19156. @d one_byte(#)== #>=0 then if #<256
  19157. @<Declare generic font output procedures@>=
  19158. procedure gf_boc(@!min_m,@!max_m,@!min_n,@!max_n:integer);
  19159. label exit;
  19160. begin if min_m<gf_min_m then gf_min_m:=min_m;
  19161. if max_n>gf_max_n then gf_max_n:=max_n;
  19162. if boc_p=-1 then if one_byte(boc_c) then
  19163.  if one_byte(max_m-min_m) then if one_byte(max_m) then
  19164.   if one_byte(max_n-min_n) then if one_byte(max_n) then
  19165.   begin gf_out(boc1); gf_out(boc_c);@/
  19166.   gf_out(max_m-min_m); gf_out(max_m);
  19167.   gf_out(max_n-min_n); gf_out(max_n); return;
  19168.   end;
  19169. gf_out(boc); gf_four(boc_c); gf_four(boc_p);@/
  19170. gf_four(min_m); gf_four(max_m); gf_four(min_n); gf_four(max_n);
  19171. exit: end;
  19172. @ Two of the parameters to |gf_boc| are global.
  19173. @<Glob...@>=
  19174. @!boc_c,@!boc_p:integer; {parameters of the next |boc| command}
  19175. @ Here is a routine that gets a \.{GF} file off to a good start.
  19176. @d check_gf==@t@>@+if output_file_name=0 then init_gf
  19177. @<Declare generic font output procedures@>=
  19178. procedure init_gf;
  19179. var @!k:eight_bits; {runs through all possible character codes}
  19180. @!t:integer; {the time of this run}
  19181. begin gf_min_m:=4096; gf_max_m:=-4096; gf_min_n:=4096; gf_max_n:=-4096;
  19182. for k:=0 to 255 do char_ptr[k]:=-1;
  19183. @<Determine the file extension, |gf_ext|@>;
  19184. set_output_file_name;
  19185. gf_out(pre); gf_out(gf_id_byte); {begin to output the preamble}
  19186. old_setting:=selector; selector:=new_string; print(" METAFONT output ");
  19187. print_int(round_unscaled(internal[year])); print_char(".");
  19188. print_dd(round_unscaled(internal[month])); print_char(".");
  19189. print_dd(round_unscaled(internal[day])); print_char(":");@/
  19190. t:=round_unscaled(internal[time]);
  19191. print_dd(t div 60); print_dd(t mod 60);@/
  19192. selector:=old_setting; gf_out(cur_length);
  19193. str_start[str_ptr+1]:=pool_ptr; gf_string(0,str_ptr);
  19194. pool_ptr:=str_start[str_ptr]; {flush that string from memory}
  19195. gf_prev_ptr:=gf_offset+gf_ptr;
  19196. @ @<Determine the file extension...@>=
  19197. if internal[hppp]<=0 then gf_ext:=".gf"
  19198. else  begin old_setting:=selector; selector:=new_string; print_char(".");
  19199.   print_int(make_scaled(internal[hppp],59429463));
  19200.     {$2^{32}/72.27\approx59429463.07$}
  19201.   print("gf"); gf_ext:=make_string; selector:=old_setting;
  19202.   end
  19203. @ With those preliminaries out of the way, |ship_out| is not especially
  19204. difficult.
  19205. @<Declare generic font output procedures@>=
  19206. procedure ship_out(@!c:eight_bits);
  19207. label done;
  19208. var @!f:integer; {current character extension}
  19209. @!prev_m,@!m,@!mm:integer; {previous and current pixel column numbers}
  19210. @!prev_n,@!n:integer; {previous and current pixel row numbers}
  19211. @!p,@!q:pointer; {for list traversal}
  19212. @!prev_w,@!w,@!ww:integer; {old and new weights}
  19213. @!d:integer; {data from edge-weight node}
  19214. @!delta:integer; {number of rows to skip}
  19215. @!cur_min_m:integer; {starting column, relative to the current offset}
  19216. @!x_off,@!y_off:integer; {offsets, rounded to integers}
  19217. begin check_gf; f:=round_unscaled(internal[char_ext]);@/
  19218. x_off:=round_unscaled(internal[x_offset]);
  19219. y_off:=round_unscaled(internal[y_offset]);
  19220. if term_offset>max_print_line-9 then print_ln
  19221. else if (term_offset>0)or(file_offset>0) then print_char(" ");
  19222. print_char("["); print_int(c);
  19223. if f<>0 then
  19224.   begin print_char("."); print_int(f);
  19225.   end;
  19226. update_terminal;
  19227. boc_c:=256*f+c; boc_p:=char_ptr[c]; char_ptr[c]:=gf_prev_ptr;@/
  19228. if internal[proofing]>0 then @<Send nonzero offsets to the output file@>;
  19229. @<Output the character represented in |cur_edges|@>;
  19230. gf_out(eoc); gf_prev_ptr:=gf_offset+gf_ptr; incr(total_chars);
  19231. print_char("]"); update_terminal; {progress report}
  19232. if internal[tracing_output]>0 then
  19233.   print_edges(" (just shipped out)",true,x_off,y_off);
  19234. @ @<Send nonzero offsets to the output file@>=
  19235. begin if x_off<>0 then
  19236.   begin gf_string("xoffset",0); gf_out(yyy); gf_four(x_off*unity);
  19237.   end;
  19238. if y_off<>0 then
  19239.   begin gf_string("yoffset",0); gf_out(yyy); gf_four(y_off*unity);
  19240.   end;
  19241. @ @<Output the character represented in |cur_edges|@>=
  19242. prev_n:=4096; p:=knil(cur_edges); n:=n_max(cur_edges)-zero_field;
  19243. while p<>cur_edges do
  19244.   begin @<Output the pixels of edge row |p| to font row |n|@>;
  19245.   p:=knil(p); decr(n);
  19246.   end;
  19247. if prev_n=4096 then @<Finish off an entirely blank character@>
  19248. else if prev_n+y_off<gf_min_n then
  19249.   gf_min_n:=prev_n+y_off
  19250. @ @<Finish off an entirely blank...@>=
  19251. begin gf_boc(0,0,0,0);
  19252. if gf_max_m<0 then gf_max_m:=0;
  19253. if gf_min_n>0 then gf_min_n:=0;
  19254. @ In this loop, |prev_w| represents the weight at column |prev_m|, which is
  19255. the most recent column reflected in the output so far; |w| represents the
  19256. weight at column~|m|, which is the most recent column in the edge data.
  19257. Several edges might cancel at the same column position, so we need to
  19258. look ahead to column~|mm| before actually outputting anything.
  19259. @<Output the pixels of edge row |p| to font row |n|@>=
  19260. if unsorted(p)>void then sort_edges(p);
  19261. q:=sorted(p); w:=0; prev_m:=-fraction_one; {$|fraction_one|\approx\infty$}
  19262. ww:=0; prev_w:=0; m:=prev_m;
  19263. repeat if q=sentinel then mm:=fraction_one
  19264. else  begin d:=ho(info(q)); mm:=d div 8; ww:=ww+(d mod 8)-zero_w;
  19265.   end;
  19266. if mm<>m then
  19267.   begin if prev_w<=0 then
  19268.     begin if w>0 then @<Start black at $(m,n)$@>;
  19269.     end
  19270.   else if w<=0 then @<Stop black at $(m,n)$@>;
  19271.   m:=mm;
  19272.   end;
  19273. w:=ww; q:=link(q);
  19274. until mm=fraction_one;
  19275. if w<>0 then {this should be impossible}
  19276.   print_nl("(There's unbounded black in character shipped out!)");
  19277. @.There's unbounded black...@>
  19278. if prev_m-m_offset(cur_edges)+x_off>gf_max_m then
  19279.   gf_max_m:=prev_m-m_offset(cur_edges)+x_off
  19280. @ @<Start black at $(m,n)$@>=
  19281. begin if prev_m=-fraction_one then @<Start a new row at $(m,n)$@>
  19282. else gf_paint(m-prev_m);
  19283. prev_m:=m; prev_w:=w;
  19284. @ @<Stop black at $(m,n)$@>=
  19285. begin gf_paint(m-prev_m); prev_m:=m; prev_w:=w;
  19286. @ @<Start a new row at $(m,n)$@>=
  19287. begin if prev_n=4096 then
  19288.   begin gf_boc(m_min(cur_edges)+x_off-zero_field,
  19289.     m_max(cur_edges)+x_off-zero_field,@|
  19290.     n_min(cur_edges)+y_off-zero_field,n+y_off);
  19291.   cur_min_m:=m_min(cur_edges)-zero_field+m_offset(cur_edges);
  19292.   end
  19293. else if prev_n>n+1 then @<Skip down |prev_n-n| rows@>
  19294. else @<Skip to column $m$ in the next row and |goto done|, or skip zero rows@>;
  19295. gf_paint(m-cur_min_m); {skip to column $m$, painting white}
  19296. done:prev_n:=n;
  19297. @ @<Skip to column $m$ in the next row...@>=
  19298. begin delta:=m-cur_min_m;
  19299. if delta>max_new_row then gf_out(skip0)
  19300. else  begin gf_out(new_row_0+delta); goto done;
  19301.   end;
  19302. @ @<Skip down...@>=
  19303. begin delta:=prev_n-n-1;
  19304. if delta<@'400 then
  19305.   begin gf_out(skip1); gf_out(delta);
  19306.   end
  19307. else  begin gf_out(skip1+1); gf_two(delta);
  19308.   end;
  19309. @ Now that we've finished |ship_out|, let's look at the other commands
  19310. by which a user can send things to the \.{GF} file.
  19311. @<Cases of |do_statement|...@>=
  19312. special_command: do_special;
  19313. @ @<Put each...@>=
  19314. primitive("special",special_command,string_type);@/
  19315. @!@:special_}{\&{special} primitive@>
  19316. primitive("numspecial",special_command,known);@/
  19317. @!@:num_special_}{\&{numspecial} primitive@>
  19318. @ @<Declare action procedures for use by |do_statement|@>=
  19319. procedure do_special;
  19320. var @!m:small_number; {either |string_type| or |known|}
  19321. begin m:=cur_mod; get_x_next; scan_expression;
  19322. if internal[proofing]>=0 then
  19323.   if cur_type<>m then @<Complain about improper special operation@>
  19324.   else  begin check_gf;
  19325.     if m=string_type then gf_string(cur_exp,0)
  19326.     else  begin gf_out(yyy); gf_four(cur_exp);
  19327.       end;
  19328.     end;
  19329. flush_cur_exp(0);
  19330. @ @<Complain about improper special operation@>=
  19331. begin exp_err("Unsuitable expression");
  19332. @.Unsuitable expression@>
  19333. help1("The expression shown above has the wrong type to be output.");
  19334. put_get_error;
  19335. @ @<Send the current expression as a title to the output file@>=
  19336. begin check_gf; gf_string("title ",cur_exp);
  19337. @ @<Cases of |print_cmd...@>=
  19338. special_command:if m=known then print("numspecial")
  19339.   else print("special");
  19340. @ @<Determine if a character has been shipped out@>=
  19341. begin cur_exp:=round_unscaled(cur_exp) mod 256;
  19342. if cur_exp<0 then cur_exp:=cur_exp+256;
  19343. boolean_reset(char_exists[cur_exp]); cur_type:=boolean_type;
  19344. @ At the end of the program we must finish things off by writing the postamble.
  19345. The \.{TFM} information should have been computed first.
  19346. An integer variable |k| and a |scaled| variable |x| will be declared for
  19347. use by this routine.
  19348. @<Finish the \.{GF} file@>=
  19349. begin gf_out(post); {beginning of the postamble}
  19350. gf_four(gf_prev_ptr); gf_prev_ptr:=gf_offset+gf_ptr-5; {|post| location}
  19351. gf_four(internal[design_size]*16);
  19352. for k:=1 to 4 do gf_out(header_byte[k]); {the check sum}
  19353. gf_four(internal[hppp]);
  19354. gf_four(internal[vppp]);@/
  19355. gf_four(gf_min_m); gf_four(gf_max_m);
  19356. gf_four(gf_min_n); gf_four(gf_max_n);
  19357. for k:=0 to 255 do if char_exists[k] then
  19358.   begin x:=gf_dx[k] div unity;
  19359.   if (gf_dy[k]=0)and(x>=0)and(x<256)and(gf_dx[k]=x*unity) then
  19360.     begin gf_out(char_loc+1); gf_out(k); gf_out(x);
  19361.     end
  19362.   else  begin gf_out(char_loc); gf_out(k);
  19363.     gf_four(gf_dx[k]); gf_four(gf_dy[k]);
  19364.     end;
  19365.   x:=value(tfm_width[k]);
  19366.   if abs(x)>max_tfm_dimen then
  19367.     if x>0 then x:=three_bytes-1@+else x:=1-three_bytes
  19368.   else x:=make_scaled(x*16,internal[design_size]);
  19369.   gf_four(x); gf_four(char_ptr[k]);
  19370.   end;
  19371. gf_out(post_post); gf_four(gf_prev_ptr); gf_out(gf_id_byte);@/
  19372. k:=4+((gf_buf_size-gf_ptr) mod 4); {the number of 223's}
  19373. while k>0 do
  19374.   begin gf_out(223); decr(k);
  19375.   end;
  19376. @<Empty the last bytes out of |gf_buf|@>;
  19377. print_nl("Output written on "); slow_print(output_file_name);
  19378. @.Output written...@>
  19379. print(" ("); print_int(total_chars); print(" character");
  19380. if total_chars<>1 then print_char("s");
  19381. print(", "); print_int(gf_offset+gf_ptr); print(" bytes).");
  19382. b_close(gf_file);
  19383. @* \[48] Dumping and undumping the tables.
  19384. After \.{INIMF} has seen a collection of macros, it
  19385. can write all the necessary information on an auxiliary file so
  19386. that production versions of \MF\ are able to initialize their
  19387. memory at high speed. The present section of the program takes
  19388. care of such output and input. We shall consider simultaneously
  19389. the processes of storing and restoring,
  19390. so that the inverse relation between them is clear.
  19391. @.INIMF@>
  19392. The global variable |base_ident| is a string that is printed right
  19393. after the |banner| line when \MF\ is ready to start. For \.{INIMF} this
  19394. string says simply `\.{(INIMF)}'; for other versions of \MF\ it says,
  19395. for example, `\.{(preloaded base=plain 84.2.29)}', showing the year,
  19396. month, and day that the base file was created. We have |base_ident=0|
  19397. before \MF's tables are loaded.
  19398. @<Glob...@>=
  19399. @!base_ident:str_number;
  19400. @ @<Set init...@>=
  19401. base_ident:=0;
  19402. @ @<Initialize table entries...@>=
  19403. base_ident:=" (INIMF)";
  19404. @ @<Declare act...@>=
  19405. @!init procedure store_base_file;
  19406. var @!k:integer; {all-purpose index}
  19407. @!p,@!q: pointer; {all-purpose pointers}
  19408. @!x: integer; {something to dump}
  19409. @!w: four_quarters; {four ASCII codes}
  19410. begin @<Create the |base_ident|, open the base file,
  19411.   and inform the user that dumping has begun@>;
  19412. @<Dump constants for consistency check@>;
  19413. @<Dump the string pool@>;
  19414. @<Dump the dynamic memory@>;
  19415. @<Dump the table of equivalents and the hash table@>;
  19416. @<Dump a few more things and the closing check word@>;
  19417. @<Close the base file@>;
  19418. @ Corresponding to the procedure that dumps a base file, we also have a function
  19419. that reads~one~in. The function returns |false| if the dumped base is
  19420. incompatible with the present \MF\ table sizes, etc.
  19421. @d off_base=6666 {go here if the base file is unacceptable}
  19422. @d too_small(#)==begin wake_up_terminal;
  19423.   wterm_ln('---! Must increase the ',#);
  19424. @.Must increase the x@>
  19425.   goto off_base;
  19426.   end
  19427. @p @t\4@>@<Declare the function called |open_base_file|@>@;
  19428. function load_base_file:boolean;
  19429. label off_base,exit;
  19430. var @!k:integer; {all-purpose index}
  19431. @!p,@!q: pointer; {all-purpose pointers}
  19432. @!x: integer; {something undumped}
  19433. @!w: four_quarters; {four ASCII codes}
  19434. begin @<Undump constants for consistency check@>;
  19435. @<Undump the string pool@>;
  19436. @<Undump the dynamic memory@>;
  19437. @<Undump the table of equivalents and the hash table@>;
  19438. @<Undump a few more things and the closing check word@>;
  19439. load_base_file:=true; return; {it worked!}
  19440. off_base: wake_up_terminal;
  19441.   wterm_ln('(Fatal base file error; I''m stymied)');
  19442. @.Fatal base file error@>
  19443. load_base_file:=false;
  19444. exit:end;
  19445. @ Base files consist of |memory_word| items, and we use the following
  19446. macros to dump words of different types:
  19447. @d dump_wd(#)==begin base_file^:=#; put(base_file);@+end
  19448. @d dump_int(#)==begin base_file^.int:=#; put(base_file);@+end
  19449. @d dump_hh(#)==begin base_file^.hh:=#; put(base_file);@+end
  19450. @d dump_qqqq(#)==begin base_file^.qqqq:=#; put(base_file);@+end
  19451. @<Glob...@>=
  19452. @!base_file:word_file; {for input or output of base information}
  19453. @ The inverse macros are slightly more complicated, since we need to check
  19454. the range of the values we are reading in. We say `|undump(a)(b)(x)|' to
  19455. read an integer value |x| that is supposed to be in the range |a<=x<=b|.
  19456. @d undump_wd(#)==begin get(base_file); #:=base_file^;@+end
  19457. @d undump_int(#)==begin get(base_file); #:=base_file^.int;@+end
  19458. @d undump_hh(#)==begin get(base_file); #:=base_file^.hh;@+end
  19459. @d undump_qqqq(#)==begin get(base_file); #:=base_file^.qqqq;@+end
  19460. @d undump_end_end(#)==#:=x;@+end
  19461. @d undump_end(#)==(x>#) then goto off_base@+else undump_end_end
  19462. @d undump(#)==begin undump_int(x); if (x<#) or undump_end
  19463. @d undump_size_end_end(#)==too_small(#)@+else undump_end_end
  19464. @d undump_size_end(#)==if x># then undump_size_end_end
  19465. @d undump_size(#)==begin undump_int(x);
  19466.   if x<# then goto off_base; undump_size_end
  19467. @ The next few sections of the program should make it clear how we use the
  19468. dump/undump macros.
  19469. @<Dump constants for consistency check@>=
  19470. dump_int(@$);@/
  19471. dump_int(mem_min);@/
  19472. dump_int(mem_top);@/
  19473. dump_int(hash_size);@/
  19474. dump_int(hash_prime);@/
  19475. dump_int(max_in_open)
  19476. @ Sections of a \.{WEB} program that are ``commented out'' still contribute
  19477. strings to the string pool; therefore \.{INIMF} and \MF\ will have
  19478. the same strings. (And it is, of course, a good thing that they do.)
  19479. @.WEB@>
  19480. @^string pool@>
  19481. @<Undump constants for consistency check@>=
  19482. x:=base_file^.int;
  19483. if x<>@$ then goto off_base; {check that strings are the same}
  19484. undump_int(x);
  19485. if x<>mem_min then goto off_base;
  19486. undump_int(x);
  19487. if x<>mem_top then goto off_base;
  19488. undump_int(x);
  19489. if x<>hash_size then goto off_base;
  19490. undump_int(x);
  19491. if x<>hash_prime then goto off_base;
  19492. undump_int(x);
  19493. if x<>max_in_open then goto off_base
  19494. @ @d dump_four_ASCII==
  19495.   w.b0:=qi(so(str_pool[k])); w.b1:=qi(so(str_pool[k+1]));
  19496.   w.b2:=qi(so(str_pool[k+2])); w.b3:=qi(so(str_pool[k+3]));
  19497.   dump_qqqq(w)
  19498. @<Dump the string pool@>=
  19499. dump_int(pool_ptr);
  19500. dump_int(str_ptr);
  19501. for k:=0 to str_ptr do dump_int(str_start[k]);
  19502. k:=0;
  19503. while k+4<pool_ptr do
  19504.   begin dump_four_ASCII; k:=k+4;
  19505.   end;
  19506. k:=pool_ptr-4; dump_four_ASCII;
  19507. print_ln; print_int(str_ptr); print(" strings of total length ");
  19508. print_int(pool_ptr)
  19509. @ @d undump_four_ASCII==
  19510.   undump_qqqq(w);
  19511.   str_pool[k]:=si(qo(w.b0)); str_pool[k+1]:=si(qo(w.b1));
  19512.   str_pool[k+2]:=si(qo(w.b2)); str_pool[k+3]:=si(qo(w.b3))
  19513. @<Undump the string pool@>=
  19514. undump_size(0)(pool_size)('string pool size')(pool_ptr);
  19515. undump_size(0)(max_strings)('max strings')(str_ptr);
  19516. for k:=0 to str_ptr do
  19517.   begin undump(0)(pool_ptr)(str_start[k]); str_ref[k]:=max_str_ref;
  19518.   end;
  19519. k:=0;
  19520. while k+4<pool_ptr do
  19521.   begin undump_four_ASCII; k:=k+4;
  19522.   end;
  19523. k:=pool_ptr-4; undump_four_ASCII;
  19524. init_str_ptr:=str_ptr; init_pool_ptr:=pool_ptr;
  19525. max_str_ptr:=str_ptr; max_pool_ptr:=pool_ptr
  19526. @ By sorting the list of available spaces in the variable-size portion of
  19527. |mem|, we are usually able to get by without having to dump very much
  19528. of the dynamic memory.
  19529. We recompute |var_used| and |dyn_used|, so that \.{INIMF} dumps valid
  19530. information even when it has not been gathering statistics.
  19531. @<Dump the dynamic memory@>=
  19532. sort_avail; var_used:=0;
  19533. dump_int(lo_mem_max); dump_int(rover);
  19534. p:=mem_min; q:=rover; x:=0;
  19535. repeat for k:=p to q+1 do dump_wd(mem[k]);
  19536. x:=x+q+2-p; var_used:=var_used+q-p;
  19537. p:=q+node_size(q); q:=rlink(q);
  19538. until q=rover;
  19539. var_used:=var_used+lo_mem_max-p; dyn_used:=mem_end+1-hi_mem_min;@/
  19540. for k:=p to lo_mem_max do dump_wd(mem[k]);
  19541. x:=x+lo_mem_max+1-p;
  19542. dump_int(hi_mem_min); dump_int(avail);
  19543. for k:=hi_mem_min to mem_end do dump_wd(mem[k]);
  19544. x:=x+mem_end+1-hi_mem_min;
  19545. p:=avail;
  19546. while p<>null do
  19547.   begin decr(dyn_used); p:=link(p);
  19548.   end;
  19549. dump_int(var_used); dump_int(dyn_used);
  19550. print_ln; print_int(x);
  19551. print(" memory locations dumped; current usage is ");
  19552. print_int(var_used); print_char("&"); print_int(dyn_used)
  19553. @ @<Undump the dynamic memory@>=
  19554. undump(lo_mem_stat_max+1000)(hi_mem_stat_min-1)(lo_mem_max);
  19555. undump(lo_mem_stat_max+1)(lo_mem_max)(rover);
  19556. p:=mem_min; q:=rover;
  19557. repeat for k:=p to q+1 do undump_wd(mem[k]);
  19558. p:=q+node_size(q);
  19559. if (p>lo_mem_max)or((q>=rlink(q))and(rlink(q)<>rover)) then goto off_base;
  19560. q:=rlink(q);
  19561. until q=rover;
  19562. for k:=p to lo_mem_max do undump_wd(mem[k]);
  19563. undump(lo_mem_max+1)(hi_mem_stat_min)(hi_mem_min);
  19564. undump(null)(mem_top)(avail); mem_end:=mem_top;
  19565. for k:=hi_mem_min to mem_end do undump_wd(mem[k]);
  19566. undump_int(var_used); undump_int(dyn_used)
  19567. @ A different scheme is used to compress the hash table, since its lower region
  19568. is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three
  19569. words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely
  19570. packed for |p>=hash_used|, so the remaining entries are output in~a~block.
  19571. @<Dump the table of equivalents and the hash table@>=
  19572. dump_int(hash_used); st_count:=frozen_inaccessible-1-hash_used;
  19573. for p:=1 to hash_used do if text(p)<>0 then
  19574.   begin dump_int(p); dump_hh(hash[p]); dump_hh(eqtb[p]); incr(st_count);
  19575.   end;
  19576. for p:=hash_used+1 to hash_end do
  19577.   begin dump_hh(hash[p]); dump_hh(eqtb[p]);
  19578.   end;
  19579. dump_int(st_count);@/
  19580. print_ln; print_int(st_count); print(" symbolic tokens")
  19581. @ @<Undump the table of equivalents and the hash table@>=
  19582. undump(1)(frozen_inaccessible)(hash_used); p:=0;
  19583. repeat undump(p+1)(hash_used)(p); undump_hh(hash[p]); undump_hh(eqtb[p]);
  19584. until p=hash_used;
  19585. for p:=hash_used+1 to hash_end do
  19586.   begin undump_hh(hash[p]); undump_hh(eqtb[p]);
  19587.   end;
  19588. undump_int(st_count)
  19589. @ We have already printed a lot of statistics, so we set |tracing_stats:=0|
  19590. to prevent them appearing again.
  19591. @<Dump a few more things and the closing check word@>=
  19592. dump_int(int_ptr);
  19593. for k:=1 to int_ptr do
  19594.   begin dump_int(internal[k]); dump_int(int_name[k]);
  19595.   end;
  19596. dump_int(start_sym); dump_int(interaction); dump_int(base_ident);
  19597. dump_int(bg_loc); dump_int(eg_loc); dump_int(serial_no); dump_int(69069);
  19598. internal[tracing_stats]:=0
  19599. @ @<Undump a few more things and the closing check word@>=
  19600. undump(max_given_internal)(max_internal)(int_ptr);
  19601. for k:=1 to int_ptr do
  19602.   begin undump_int(internal[k]);
  19603.   undump(0)(str_ptr)(int_name[k]);
  19604.   end;
  19605. undump(0)(frozen_inaccessible)(start_sym);
  19606. undump(batch_mode)(error_stop_mode)(interaction);
  19607. undump(0)(str_ptr)(base_ident);
  19608. undump(1)(hash_end)(bg_loc);
  19609. undump(1)(hash_end)(eg_loc);
  19610. undump_int(serial_no);@/
  19611. undump_int(x);@+if (x<>69069)or eof(base_file) then goto off_base
  19612. @ @<Create the |base_ident|...@>=
  19613. selector:=new_string;
  19614. print(" (preloaded base="); print(job_name); print_char(" ");
  19615. print_int(round_unscaled(internal[year]) mod 100); print_char(".");
  19616. print_int(round_unscaled(internal[month])); print_char(".");
  19617. print_int(round_unscaled(internal[day])); print_char(")");
  19618. if interaction=batch_mode then selector:=log_only
  19619. else selector:=term_and_log;
  19620. str_room(1); base_ident:=make_string; str_ref[base_ident]:=max_str_ref;@/
  19621. pack_job_name(base_extension);
  19622. while not w_open_out(base_file) do
  19623.  prompt_file_name("base file name",base_extension);
  19624. print_nl("Beginning to dump on file ");
  19625. @.Beginning to dump...@>
  19626. slow_print(w_make_name_string(base_file)); flush_string(str_ptr-1);
  19627. print_nl(""); slow_print(base_ident)
  19628. @ @<Close the base file@>=
  19629. w_close(base_file)
  19630. @* \[49] The main program.
  19631. This is it: the part of \MF\ that executes all those procedures we have
  19632. written.
  19633. Well---almost. We haven't put the parsing subroutines into the
  19634. program yet; and we'd better leave space for a few more routines that may
  19635. have been forgotten.
  19636. @p @<Declare the basic parsing subroutines@>@;
  19637. @<Declare miscellaneous procedures that were declared |forward|@>@;
  19638. @<Last-minute procedures@>
  19639. @ We've noted that there are two versions of \MF84. One, called \.{INIMF},
  19640. @.INIMF@>
  19641. has to be run first; it initializes everything from scratch, without
  19642. reading a base file, and it has the capability of dumping a base file.
  19643. The other one is called `\.{VIRMF}'; it is a ``virgin'' program that needs
  19644. @.VIRMF@>
  19645. to input a base file in order to get started. \.{VIRMF} typically has
  19646. a bit more memory capacity than \.{INIMF}, because it does not need the
  19647. space consumed by the dumping/undumping routines and the numerous calls on
  19648. |primitive|, etc.
  19649. The \.{VIRMF} program cannot read a base file instantaneously, of course;
  19650. the best implementations therefore allow for production versions of \MF\ that
  19651. not only avoid the loading routine for \PASCAL\ object code, they also have
  19652. a base file pre-loaded. This is impossible to do if we stick to standard
  19653. \PASCAL; but there is a simple way to fool many systems into avoiding the
  19654. initialization, as follows:\quad(1)~We declare a global integer variable
  19655. called |ready_already|. The probability is negligible that this
  19656. variable holds any particular value like 314159 when \.{VIRMF} is first
  19657. loaded.\quad(2)~After we have read in a base file and initialized
  19658. everything, we set |ready_already:=314159|.\quad(3)~Soon \.{VIRMF}
  19659. will print `\.*', waiting for more input; and at this point we
  19660. interrupt the program and save its core image in some form that the
  19661. operating system can reload speedily.\quad(4)~When that core image is
  19662. activated, the program starts again at the beginning; but now
  19663. |ready_already=314159| and all the other global variables have
  19664. their initial values too. The former chastity has vanished!
  19665. In other words, if we allow ourselves to test the condition
  19666. |ready_already=314159|, before |ready_already| has been
  19667. assigned a value, we can avoid the lengthy initialization. Dirty tricks
  19668. rarely pay off so handsomely.
  19669. @^dirty \PASCAL@>
  19670. @^system dependencies@>
  19671. On systems that allow such preloading, the standard program called \.{MF}
  19672. should be the one that has \.{plain} base preloaded, since that agrees
  19673. with {\sl The {\logos METAFONT\/}book}.  Other versions, e.g., \.{cmbase},
  19674. should also be provided for commonly used bases.
  19675. @:METAFONTbook}{\sl The {\logos METAFONT\/}book@>
  19676. @.cmbase@>
  19677. @.plain@>
  19678. @<Glob...@>=
  19679. @!ready_already:integer; {a sacrifice of purity for economy}
  19680. @ Now this is really it: \MF\ starts and ends here.
  19681. The initial test involving |ready_already| should be deleted if the
  19682. \PASCAL\ runtime system is smart enough to detect such a ``mistake.''
  19683. @^system dependencies@>
  19684. @p begin @!{|start_here|}
  19685. history:=fatal_error_stop; {in case we quit during initialization}
  19686. t_open_out; {open the terminal for output}
  19687. if ready_already=314159 then goto start_of_MF;
  19688. @<Check the ``constant'' values...@>@;
  19689. if bad>0 then
  19690.   begin wterm_ln('Ouch---my internal constants have been clobbered!',
  19691.     '---case ',bad:1);
  19692. @.Ouch...clobbered@>
  19693.   goto final_end;
  19694.   end;
  19695. initialize; {set global variables to their starting values}
  19696. @!init if not get_strings_started then goto final_end;
  19697. init_tab; {initialize the tables}
  19698. init_prim; {call |primitive| for each primitive}
  19699. init_str_ptr:=str_ptr; init_pool_ptr:=pool_ptr;@/
  19700. max_str_ptr:=str_ptr; max_pool_ptr:=pool_ptr; fix_date_and_time;
  19701. tini@/
  19702. ready_already:=314159;
  19703. start_of_MF: @<Initialize the output routines@>;
  19704. @<Get the first line of input and prepare to start@>;
  19705. history:=spotless; {ready to go!}
  19706. if start_sym>0 then {insert the `\&{everyjob}' symbol}
  19707.   begin cur_sym:=start_sym; back_input;
  19708.   end;
  19709. main_control; {come to life}
  19710. final_cleanup; {prepare for death}
  19711. end_of_MF: close_files_and_terminate;
  19712. final_end: ready_already:=0;
  19713. @ Here we do whatever is needed to complete \MF's job gracefully on the
  19714. local operating system. The code here might come into play after a fatal
  19715. error; it must therefore consist entirely of ``safe'' operations that
  19716. cannot produce error messages. For example, it would be a mistake to call
  19717. |str_room| or |make_string| at this time, because a call on |overflow|
  19718. might lead to an infinite loop.
  19719. @^system dependencies@>
  19720. This program doesn't bother to close the input files that may still be open.
  19721. @<Last-minute...@>=
  19722. procedure close_files_and_terminate;
  19723. var @!k:integer; {all-purpose index}
  19724. @!lh:integer; {the length of the \.{TFM} header, in words}
  19725. @!lk_offset:0..256; {extra words inserted at beginning of |lig_kern| array}
  19726. @!p:pointer; {runs through a list of \.{TFM} dimensions}
  19727. @!x:scaled; {a |tfm_width| value being output to the \.{GF} file}
  19728. begin
  19729. @!stat if internal[tracing_stats]>0 then
  19730.   @<Output statistics about this job@>;@;@+tats@/
  19731. wake_up_terminal; @<Finish the \.{TFM} and \.{GF} files@>;
  19732. if log_opened then
  19733.   begin wlog_cr;
  19734.   a_close(log_file); selector:=selector-2;
  19735.   if selector=term_only then
  19736.     begin print_nl("Transcript written on ");
  19737. @.Transcript written...@>
  19738.     slow_print(log_name); print_char(".");
  19739.     end;
  19740.   end;
  19741. @ We want to finish the \.{GF} file if and only if it has already been started;
  19742. this will be true if and only if |gf_prev_ptr| is positive.
  19743. We want to produce a \.{TFM} file if and only if |fontmaking| is positive.
  19744. The \.{TFM} widths must be computed if there's a \.{GF} file, even if
  19745. there's going to be no \.{TFM}~file.
  19746. We reclaim all of the variable-size memory at this point, so that
  19747. there is no chance of another memory overflow after the memory capacity
  19748. has already been exceeded.
  19749. @<Finish the \.{TFM} and \.{GF} files@>=
  19750. if (gf_prev_ptr>0)or(internal[fontmaking]>0) then
  19751.   begin @<Make the dynamic memory into one big available node@>;
  19752.   @<Massage the \.{TFM} widths@>;
  19753.   fix_design_size; fix_check_sum;
  19754.   if internal[fontmaking]>0 then
  19755.     begin @<Massage the \.{TFM} heights, depths, and italic corrections@>;
  19756.     internal[fontmaking]:=0; {avoid loop in case of fatal error}
  19757.     @<Finish the \.{TFM} file@>;
  19758.     end;
  19759.   if gf_prev_ptr>0 then @<Finish the \.{GF} file@>;
  19760.   end
  19761. @ @<Make the dynamic memory into one big available node@>=
  19762. rover:=lo_mem_stat_max+1; link(rover):=empty_flag; lo_mem_max:=hi_mem_min-1;
  19763. if lo_mem_max-rover>max_halfword then lo_mem_max:=max_halfword+rover;
  19764. node_size(rover):=lo_mem_max-rover; llink(rover):=rover; rlink(rover):=rover;
  19765. link(lo_mem_max):=null; info(lo_mem_max):=null
  19766. @ The present section goes directly to the log file instead of using
  19767. |print| commands, because there's no need for these strings to take
  19768. up |str_pool| memory when a non-{\bf stat} version of \MF\ is being used.
  19769. @<Output statistics...@>=
  19770. if log_opened then
  19771.   begin wlog_ln(' ');
  19772.   wlog_ln('Here is how much of METAFONT''s memory',' you used:');
  19773. @.Here is how much...@>
  19774.   wlog(' ',max_str_ptr-init_str_ptr:1,' string');
  19775.   if max_str_ptr<>init_str_ptr+1 then wlog('s');
  19776.   wlog_ln(' out of ', max_strings-init_str_ptr:1);@/
  19777.   wlog_ln(' ',max_pool_ptr-init_pool_ptr:1,' string characters out of ',
  19778.     pool_size-init_pool_ptr:1);@/
  19779.   wlog_ln(' ',lo_mem_max-mem_min+mem_end-hi_mem_min+2:1,@|
  19780.     ' words of memory out of ',mem_end+1-mem_min:1);@/
  19781.   wlog_ln(' ',st_count:1,' symbolic tokens out of ',
  19782.     hash_size:1);@/
  19783.   wlog_ln(' ',max_in_stack:1,'i,',@|
  19784.     int_ptr:1,'n,',@|
  19785.     max_rounding_ptr:1,'r,',@|
  19786.     max_param_stack:1,'p,',@|
  19787.     max_buf_stack+1:1,'b stack positions out of ',@|
  19788.     stack_size:1,'i,',
  19789.     max_internal:1,'n,',
  19790.     max_wiggle:1,'r,',
  19791.     param_size:1,'p,',
  19792.     buf_size:1,'b');
  19793.   end
  19794. @ We get to the |final_cleanup| routine when \&{end} or \&{dump} has
  19795. been scanned.
  19796. @<Last-minute...@>=
  19797. procedure final_cleanup;
  19798. label exit;
  19799. var c:small_number; {0 for \&{end}, 1 for \&{dump}}
  19800. begin c:=cur_mod;
  19801. if job_name=0 then open_log_file;
  19802. while open_parens>0 do
  19803.   begin print(" )"); decr(open_parens);
  19804.   end;
  19805. while cond_ptr<>null do
  19806.   begin print_nl("(end occurred when ");@/
  19807. @.end occurred...@>
  19808.   print_cmd_mod(fi_or_else,cur_if);
  19809.     {`\.{if}' or `\.{elseif}' or `\.{else}'}
  19810.   if if_line<>0 then
  19811.     begin print(" on line "); print_int(if_line);
  19812.     end;
  19813.   print(" was incomplete)");
  19814.   if_line:=if_line_field(cond_ptr);
  19815.   cur_if:=name_type(cond_ptr); cond_ptr:=link(cond_ptr);
  19816.   end;
  19817. if history<>spotless then
  19818.  if ((history=warning_issued)or(interaction<error_stop_mode)) then
  19819.   if selector=term_and_log then
  19820.   begin selector:=term_only;
  19821.   print_nl("(see the transcript file for additional information)");
  19822. @.see the transcript file...@>
  19823.   selector:=term_and_log;
  19824.   end;
  19825. if c=1 then
  19826.   begin @!init store_base_file; return;@+tini@/
  19827.   print_nl("(dump is performed only by INIMF)"); return;
  19828. @.dump...only by INIMF@>
  19829.   end;
  19830. exit:end;
  19831. @ @<Last-minute...@>=
  19832. @!init procedure init_prim; {initialize all the primitives}
  19833. begin
  19834. @<Put each...@>;
  19835. procedure init_tab; {initialize other tables}
  19836. var @!k:integer; {all-purpose index}
  19837. begin @<Initialize table entries (done by \.{INIMF} only)@>@;
  19838. @ When we begin the following code, \MF's tables may still contain garbage;
  19839. the strings might not even be present. Thus we must proceed cautiously to get
  19840. bootstrapped in.
  19841. But when we finish this part of the program, \MF\ is ready to call on the
  19842. |main_control| routine to do its work.
  19843. @<Get the first line...@>=
  19844. begin @<Initialize the input routines@>;
  19845. if (base_ident=0)or(buffer[loc]="&") then
  19846.   begin if base_ident<>0 then initialize; {erase preloaded base}
  19847.   if not open_base_file then goto final_end;
  19848.   if not load_base_file then
  19849.     begin w_close(base_file); goto final_end;
  19850.     end;
  19851.   w_close(base_file);
  19852.   while (loc<limit)and(buffer[loc]=" ") do incr(loc);
  19853.   end;
  19854. buffer[limit]:="%";@/
  19855. fix_date_and_time; init_randoms((internal[time] div unity)+internal[day]);@/
  19856. @<Initialize the print |selector|...@>;
  19857. if loc<limit then if buffer[loc]<>"\" then start_input; {\&{input} assumed}
  19858. @* \[50] Debugging.
  19859. Once \MF\ is working, you should be able to diagnose most errors with
  19860. the \.{show} commands and other diagnostic features. But for the initial
  19861. stages of debugging, and for the revelation of really deep mysteries, you
  19862. can compile \MF\ with a few more aids, including the \PASCAL\ runtime
  19863. checks and its debugger. An additional routine called |debug_help|
  19864. will also come into play when you type `\.D' after an error message;
  19865. |debug_help| also occurs just before a fatal error causes \MF\ to succumb.
  19866. @^debugging@>
  19867. @^system dependencies@>
  19868. The interface to |debug_help| is primitive, but it is good enough when used
  19869. with a \PASCAL\ debugger that allows you to set breakpoints and to read
  19870. variables and change their values. After getting the prompt `\.{debug \#}', you
  19871. type either a negative number (this exits |debug_help|), or zero (this
  19872. goes to a location where you can set a breakpoint, thereby entering into
  19873. dialog with the \PASCAL\ debugger), or a positive number |m| followed by
  19874. an argument |n|. The meaning of |m| and |n| will be clear from the
  19875. program below. (If |m=13|, there is an additional argument, |l|.)
  19876. @.debug \#@>
  19877. @d breakpoint=888 {place where a breakpoint is desirable}
  19878. @<Last-minute...@>=
  19879. @!debug procedure debug_help; {routine to display various things}
  19880. label breakpoint,exit;
  19881. var @!k,@!l,@!m,@!n:integer;
  19882. begin loop begin wake_up_terminal;
  19883.   print_nl("debug # (-1 to exit):"); update_terminal;
  19884. @.debug \#@>
  19885.   read(term_in,m);
  19886.   if m<0 then return
  19887.   else if m=0 then
  19888.     begin goto breakpoint;@\ {go to every label at least once}
  19889.     breakpoint: m:=0; @{'BREAKPOINT'@}@\
  19890.     end
  19891.   else  begin read(term_in,n);
  19892.     case m of
  19893.     @t\4@>@<Numbered cases for |debug_help|@>@;
  19894.     othercases print("?")
  19895.     endcases;
  19896.     end;
  19897.   end;
  19898. exit:end;
  19899. gubed
  19900. @ @<Numbered cases...@>=
  19901. 1: print_word(mem[n]); {display |mem[n]| in all forms}
  19902. 2: print_int(info(n));
  19903. 3: print_int(link(n));
  19904. 4: begin print_int(eq_type(n)); print_char(":"); print_int(equiv(n));
  19905.   end;
  19906. 5: print_variable_name(n);
  19907. 6: print_int(internal[n]);
  19908. 7: do_show_dependencies;
  19909. 9: show_token_list(n,null,100000,0);
  19910. 10: slow_print(n);
  19911. 11: check_mem(n>0); {check wellformedness; print new busy locations if |n>0|}
  19912. 12: search_mem(n); {look for pointers to |n|}
  19913. 13: begin read(term_in,l); print_cmd_mod(n,l);
  19914.   end;
  19915. 14: for k:=0 to n do print(buffer[k]);
  19916. 15: panicking:=not panicking;
  19917. @* \[51] System-dependent changes.
  19918. This section should be replaced, if necessary, by any special
  19919. modifications of the program
  19920. that are necessary to make \MF\ work at a particular installation.
  19921. It is usually best to design your change file so that all changes to
  19922. previous sections preserve the section numbering; then everybody's version
  19923. will be consistent with the published program. More extensive changes,
  19924. which introduce new sections, can be inserted here; then only the index
  19925. itself will get a new section number.
  19926. @^system dependencies@>
  19927. @* \[52] Index.
  19928. Here is where you can find all uses of each identifier in the program,
  19929. with underlined entries pointing to where the identifier was defined.
  19930. If the identifier is only one letter long, however, you get to see only
  19931. the underlined entries. {\sl All references are to section numbers instead of
  19932. page numbers.}
  19933. This index also lists error messages and other aspects of the program
  19934. that you might want to look up some day. For example, the entry
  19935. for ``system dependencies'' lists all sections that should receive
  19936. special attention from people who are installing \MF\ in a new
  19937. operating environment. A list of various things that can't happen appears
  19938. under ``this can't happen''.
  19939. Approximately 25 sections are listed under ``inner loop''; these account
  19940. for more than 60\pct! of \MF's running time, exclusive of input and output.
  19941.