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 7% TeX is a trademark of the American Mathematical Society. 8% METAFONT is a trademark of Addison-Wesley Publishing Company. 9 10% Version 0 was completed on July 28, 1984. 11% Version 1 was completed on January 4, 1986; it corresponds to "Volume D". 12% Version 1.1 trivially corrected the punctuation in one message (June 1986). 13% Version 1.2 corrected an arithmetic overflow problem (July 1986). 14% Version 1.3 improved rounding when elliptical pens are made (November 1986). 15% Version 1.4 corrected scan_declared_variable timing (May 1988). 16% Version 1.5 fixed negative halving in allocator when mem_min<0 (June 1988). 17% Version 1.6 kept open_log_file from calling fatal_error (November 1988). 18% Version 1.7 solved that problem a better way (December 1988). 19% Version 1.8 introduced major changes for 8-bit extensions (September 1989). 20% Version 1.9 improved skimping and was edited for style (December 1989). 21% Version 2.0 fixed bug in addto; released with TeX version 3.0 (March 1990). 22% Version 2.7 made consistent with TeX version 3.1 (September 1990). 23% Version 2.71 fixed bug in draw, allowed unprintable filenames (March 1992). 24% Version 2.718 fixed bug in <Choose a dependent...> (March 1995). 25% Version 2.7182 fixed bugs related to "<unprintable char>" (August 1996). 26% Version 2.71828 suppressed autorounding in dangerous cases (June 2003). 27% Version 2.718281 was a general cleanup with minor fixes (February 2008). 28% Version 2.7182818 was similar (January 2014). 29 30% A reward of $327.68 will be paid to the first finder of any remaining bug. 31 32% Although considerable effort has been expended to make the METAFONT program 33% correct and reliable, no warranty is implied; the author disclaims any 34% obligation or liability for damages, including but not limited to 35% special, indirect, or consequential damages arising out of or in 36% connection with the use or performance of this software. This work has 37% been a ``labor of love'' and the author hopes that users enjoy it. 38 39% Here is TeX material that gets inserted after \input webmac 40\def\hang{\hangindent 3em\noindent\ignorespaces} 41\def\textindent#1{\hangindent2.5em\noindent\hbox to2.5em{\hss#1 }\ignorespaces} 42\font\ninerm=cmr9 43\let\mc=\ninerm % medium caps for names like SAIL 44\def\PASCAL{Pascal} 45\def\ph{\hbox{Pascal-H}} 46\def\psqrt#1{\sqrt{\mathstrut#1}} 47\def\k{_{k+1}} 48\def\pct!{{\char`\%}} % percent sign in ordinary text 49\font\tenlogo=logo10 % font used for the METAFONT logo 50\font\logos=logosl10 51\font\eightlogo=logo8 52\def\MF{{\tenlogo META}\-{\tenlogo FONT}} 53\def\<#1>{$\langle#1\rangle$} 54\def\section{\mathhexbox278} 55\let\swap=\leftrightarrow 56\def\round{\mathop{\rm round}\nolimits} 57 58\def\(#1){} % this is used to make section names sort themselves better 59\def\9#1{} % this is used for sort keys in the index via @@:sort key}{entry@@> 60 61\outer\def\N#1. \[#2]#3.{\MN#1.\vfil\eject % begin starred section 62 \def\rhead{PART #2:\uppercase{#3}} % define running headline 63 \message{*\modno} % progress report 64 \edef\next{\write\cont{\Z{\?#2]#3}{\modno}{\the\pageno}}}\next 65 \ifon\startsection{\bf\ignorespaces#3.\quad}\ignorespaces} 66\let\?=\relax % we want to be able to \write a \? 67 68\def\title{{\eightlogo METAFONT}} 69\def\topofcontents{\hsize 5.5in 70 \vglue -30pt plus 1fil minus 1.5in 71 \def\?##1]{\hbox to 1in{\hfil##1.\ }} 72 } 73\def\botofcontents{\vskip 0pt plus 1fil minus 1.5in} 74\pageno=3 75\def\glob{13} % this should be the section number of "<Global...>" 76\def\gglob{20, 26} % this should be the next two sections of "<Global...>" 77 78@* \[1] Introduction. 79This is \MF, a font compiler intended to produce typefaces of high quality. 80The \PASCAL\ program that follows is the definition of \MF84, a standard 81@:PASCAL}{\PASCAL@> 82@!@:METAFONT84}{\MF84@> 83version of \MF\ that is designed to be highly portable so that identical output 84will be obtainable on a great variety of computers. The conventions 85of \MF84 are the same as those of \TeX82. 86 87The main purpose of the following program is to explain the algorithms of \MF\ 88as clearly as possible. As a result, the program will not necessarily be very 89efficient when a particular \PASCAL\ compiler has translated it into a 90particular machine language. However, the program has been written so that it 91can be tuned to run efficiently in a wide variety of operating environments 92by making comparatively few changes. Such flexibility is possible because 93the documentation that follows is written in the \.{WEB} language, which is 94at a higher level than \PASCAL; the preprocessing step that converts \.{WEB} 95to \PASCAL\ is able to introduce most of the necessary refinements. 96Semi-automatic translation to other languages is also feasible, because the 97program below does not make extensive use of features that are peculiar to 98\PASCAL. 99 100A large piece of software like \MF\ has inherent complexity that cannot 101be reduced below a certain level of difficulty, although each individual 102part is fairly simple by itself. The \.{WEB} language is intended to make 103the algorithms as readable as possible, by reflecting the way the 104individual program pieces fit together and by providing the 105cross-references that connect different parts. Detailed comments about 106what is going on, and about why things were done in certain ways, have 107been liberally sprinkled throughout the program. These comments explain 108features of the implementation, but they rarely attempt to explain the 109\MF\ language itself, since the reader is supposed to be familiar with 110{\sl The {\logos METAFONT\/}book}. 111@.WEB@> 112@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 113 114@ The present implementation has a long ancestry, beginning in the spring 115of~1977, when its author wrote a prototype set of subroutines and macros 116@^Knuth, Donald Ervin@> 117that were used to develop the first Computer Modern fonts. 118This original proto-\MF\ required the user to recompile a {\mc SAIL} program 119whenever any character was changed, because it was not a ``language'' for 120font design; the language was {\mc SAIL}. After several hundred characters 121had been designed in that way, the author developed an interpretable language 122called \MF, in which it was possible to express the Computer Modern programs 123less cryptically. A complete \MF\ processor was designed and coded by the 124author in 1979. This program, written in {\mc SAIL}, was adapted for use 125with a variety of typesetting equipment and display terminals by Leo Guibas, 126Lyle Ramshaw, and David Fuchs. 127@^Guibas, Leonidas Ioannis@> 128@^Ramshaw, Lyle Harold@> 129@^Fuchs, David Raymond@> 130Major improvements to the design of Computer Modern fonts were made in the 131spring of 1982, after which it became clear that a new language would 132better express the needs of letterform designers. Therefore an entirely 133new \MF\ language and system were developed in 1984; the present system 134retains the name and some of the spirit of \MF79, but all of the details 135have changed. 136 137No doubt there still is plenty of room for improvement, but the author 138is firmly committed to keeping \MF84 ``frozen'' from now on; stability 139and reliability are to be its main virtues. 140 141On the other hand, the \.{WEB} description can be extended without changing 142the core of \MF84 itself, and the program has been designed so that such 143extensions are not extremely difficult to make. 144The |banner| string defined here should be changed whenever \MF\ 145undergoes any modifications, so that it will be clear which version of 146\MF\ might be the guilty party when a problem arises. 147@^extensions to \MF@> 148@^system dependencies@> 149 150If this program is changed, the resulting system should not be called 151`\MF\kern.5pt'; the official name `\MF\kern.5pt' by itself is reserved 152for software systems that are fully compatible with each other. 153A special test suite called the ``\.{TRAP} test'' is available for 154helping to determine whether an implementation deserves to be 155known as `\MF\kern.5pt' [cf.~Stanford Computer Science report CS1095, 156January 1986]. 157 158@d banner=='This is METAFONT, Version 2.7182818' {printed when \MF\ starts} 159 160@ Different \PASCAL s have slightly different conventions, and the present 161@!@:PASCAL H}{\ph@> 162program expresses \MF\ in terms of the \PASCAL\ that was 163available to the author in 1984. Constructions that apply to 164this particular compiler, which we shall call \ph, should help the 165reader see how to make an appropriate interface for other systems 166if necessary. (\ph\ is Charles Hedrick's modification of a compiler 167@^Hedrick, Charles Locke@> 168for the DECsystem-10 that was originally developed at the University of 169Hamburg; cf.\ {\sl SOFTWARE---Practice \AM\ Experience \bf6} (1976), 17029--42. The \MF\ program below is intended to be adaptable, without 171extensive changes, to most other versions of \PASCAL, so it does not fully 172use the admirable features of \ph. Indeed, a conscious effort has been 173made here to avoid using several idiosyncratic features of standard 174\PASCAL\ itself, so that most of the code can be translated mechanically 175into other high-level languages. For example, the `\&{with}' and `\\{new}' 176features are not used, nor are pointer types, set types, or enumerated 177scalar types; there are no `\&{var}' parameters, except in the case of files 178or in the system-dependent |paint_row| procedure; 179there are no tag fields on variant records; there are no |real| variables; 180no procedures are declared local to other procedures.) 181 182The portions of this program that involve system-dependent code, where 183changes might be necessary because of differences between \PASCAL\ compilers 184and/or differences between 185operating systems, can be identified by looking at the sections whose 186numbers are listed under `system dependencies' in the index. Furthermore, 187the index entries for `dirty \PASCAL' list all places where the restrictions 188of \PASCAL\ have not been followed perfectly, for one reason or another. 189@!@^system dependencies@> 190@!@^dirty \PASCAL@> 191 192@ The program begins with a normal \PASCAL\ program heading, whose 193components will be filled in later, using the conventions of \.{WEB}. 194@.WEB@> 195For example, the portion of the program called `\X\glob:Global 196variables\X' below will be replaced by a sequence of variable declarations 197that starts in $\section\glob$ of this documentation. In this way, we are able 198to define each individual global variable when we are prepared to 199understand what it means; we do not have to define all of the globals at 200once. Cross references in $\section\glob$, where it says ``See also 201sections \gglob, \dots,'' also make it possible to look at the set of 202all global variables, if desired. Similar remarks apply to the other 203portions of the program heading. 204 205Actually the heading shown here is not quite normal: The |program| line 206does not mention any |output| file, because \ph\ would ask the \MF\ user 207to specify a file name if |output| were specified here. 208@:PASCAL H}{\ph@> 209@^system dependencies@> 210 211@d mtype==t@&y@&p@&e {this is a \.{WEB} coding trick:} 212@f mtype==type {`\&{mtype}' will be equivalent to `\&{type}'} 213@f type==true {but `|type|' will not be treated as a reserved word} 214 215@p @t\4@>@<Compiler directives@>@/ 216program MF; {all file names are defined dynamically} 217label @<Labels in the outer block@>@/ 218const @<Constants in the outer block@>@/ 219mtype @<Types in the outer block@>@/ 220var @<Global variables@>@/ 221@# 222procedure initialize; {this procedure gets things started properly} 223 var @<Local variables for initialization@>@/ 224 begin @<Set initial values of key variables@>@/ 225 end;@# 226@t\4@>@<Basic printing procedures@>@/ 227@t\4@>@<Error handling procedures@>@/ 228 229@ The overall \MF\ program begins with the heading just shown, after which 230comes a bunch of procedure declarations and function declarations. 231Finally we will get to the main program, which begins with the 232comment `|start_here|'. If you want to skip down to the 233main program now, you can look up `|start_here|' in the index. 234But the author suggests that the best way to understand this program 235is to follow pretty much the order of \MF's components as they appear in the 236\.{WEB} description you are now reading, since the present ordering is 237intended to combine the advantages of the ``bottom up'' and ``top down'' 238approaches to the problem of understanding a somewhat complicated system. 239 240@ Three labels must be declared in the main program, so we give them 241symbolic names. 242 243@d start_of_MF=1 {go here when \MF's variables are initialized} 244@d end_of_MF=9998 {go here to close files and terminate gracefully} 245@d final_end=9999 {this label marks the ending of the program} 246 247@<Labels in the out...@>= 248start_of_MF@t\hskip-2pt@>, end_of_MF@t\hskip-2pt@>,@,final_end; 249 {key control points} 250 251@ Some of the code below is intended to be used only when diagnosing the 252strange behavior that sometimes occurs when \MF\ is being installed or 253when system wizards are fooling around with \MF\ without quite knowing 254what they are doing. Such code will not normally be compiled; it is 255delimited by the codewords `$|debug|\ldots|gubed|$', with apologies 256to people who wish to preserve the purity of English. 257 258Similarly, there is some conditional code delimited by 259`$|stat|\ldots|tats|$' that is intended for use when statistics are to be 260kept about \MF's memory usage. The |stat| $\ldots$ |tats| code also 261implements special diagnostic information that is printed when 262$\\{tracingedges}>1$. 263@^debugging@> 264 265@d debug==@{ {change this to `$\\{debug}\equiv\null$' when debugging} 266@d gubed==@t@>@} {change this to `$\\{gubed}\equiv\null$' when debugging} 267@f debug==begin 268@f gubed==end 269@# 270@d stat==@{ {change this to `$\\{stat}\equiv\null$' when gathering 271 usage statistics} 272@d tats==@t@>@} {change this to `$\\{tats}\equiv\null$' when gathering 273 usage statistics} 274@f stat==begin 275@f tats==end 276 277@ This program has two important variations: (1) There is a long and slow 278version called \.{INIMF}, which does the extra calculations needed to 279@.INIMF@> 280initialize \MF's internal tables; and (2)~there is a shorter and faster 281production version, which cuts the initialization to a bare minimum. 282Parts of the program that are needed in (1) but not in (2) are delimited by 283the codewords `$|init|\ldots|tini|$'. 284 285@d init== {change this to `$\\{init}\equiv\.{@@\{}$' in the production version} 286@d tini== {change this to `$\\{tini}\equiv\.{@@\}}$' in the production version} 287@f init==begin 288@f tini==end 289 290@ If the first character of a \PASCAL\ comment is a dollar sign, 291\ph\ treats the comment as a list of ``compiler directives'' that will 292affect the translation of this program into machine language. The 293directives shown below specify full checking and inclusion of the \PASCAL\ 294debugger when \MF\ is being debugged, but they cause range checking and other 295redundant code to be eliminated when the production system is being generated. 296Arithmetic overflow will be detected in all cases. 297@:PASCAL H}{\ph@> 298@^system dependencies@> 299@^overflow in arithmetic@> 300 301@<Compiler directives@>= 302@{@&$C-,A+,D-@} {no range check, catch arithmetic overflow, no debug overhead} 303@!debug @{@&$C+,D+@}@+ gubed {but turn everything on when debugging} 304 305@ This \MF\ implementation conforms to the rules of the {\sl Pascal User 306@:PASCAL}{\PASCAL@> 307@^system dependencies@> 308Manual} published by Jensen and Wirth in 1975, except where system-dependent 309@^Wirth, Niklaus@> 310@^Jensen, Kathleen@> 311code is necessary to make a useful system program, and except in another 312respect where such conformity would unnecessarily obscure the meaning 313and clutter up the code: We assume that |case| statements may include a 314default case that applies if no matching label is found. Thus, we shall use 315constructions like 316$$\vbox{\halign{\ignorespaces#\hfil\cr 317|case x of|\cr 3181: $\langle\,$code for $x=1\,\rangle$;\cr 3193: $\langle\,$code for $x=3\,\rangle$;\cr 320|othercases| $\langle\,$code for |x<>1| and |x<>3|$\,\rangle$\cr 321|endcases|\cr}}$$ 322since most \PASCAL\ compilers have plugged this hole in the language by 323incorporating some sort of default mechanism. For example, the \ph\ 324compiler allows `|others|:' as a default label, and other \PASCAL s allow 325syntaxes like `\&{else}' or `\&{otherwise}' or `\\{otherwise}:', etc. The 326definitions of |othercases| and |endcases| should be changed to agree with 327local conventions. Note that no semicolon appears before |endcases| in 328this program, so the definition of |endcases| should include a semicolon 329if the compiler wants one. (Of course, if no default mechanism is 330available, the |case| statements of \MF\ will have to be laboriously 331extended by listing all remaining cases. People who are stuck with such 332\PASCAL s have, in fact, done this, successfully but not happily!) 333@:PASCAL H}{\ph@> 334 335@d othercases == others: {default for cases not listed explicitly} 336@d endcases == @+end {follows the default case in an extended |case| statement} 337@f othercases == else 338@f endcases == end 339 340@ The following parameters can be changed at compile time to extend or 341reduce \MF's capacity. They may have different values in \.{INIMF} and 342in production versions of \MF. 343@.INIMF@> 344@^system dependencies@> 345 346@<Constants...@>= 347@!mem_max=30000; {greatest index in \MF's internal |mem| array; 348 must be strictly less than |max_halfword|; 349 must be equal to |mem_top| in \.{INIMF}, otherwise |>=mem_top|} 350@!max_internal=100; {maximum number of internal quantities} 351@!buf_size=500; {maximum number of characters simultaneously present in 352 current lines of open files; must not exceed |max_halfword|} 353@!error_line=72; {width of context lines on terminal error messages} 354@!half_error_line=42; {width of first lines of contexts in terminal 355 error messages; should be between 30 and |error_line-15|} 356@!max_print_line=79; {width of longest text lines output; should be at least 60} 357@!screen_width=768; {number of pixels in each row of screen display} 358@!screen_depth=1024; {number of pixels in each column of screen display} 359@!stack_size=30; {maximum number of simultaneous input sources} 360@!max_strings=2000; {maximum number of strings; must not exceed |max_halfword|} 361@!string_vacancies=8000; {the minimum number of characters that should be 362 available for the user's identifier names and strings, 363 after \MF's own error messages are stored} 364@!pool_size=32000; {maximum number of characters in strings, including all 365 error messages and help texts, and the names of all identifiers; 366 must exceed |string_vacancies| by the total 367 length of \MF's own strings, which is currently about 22000} 368@!move_size=5000; {space for storing moves in a single octant} 369@!max_wiggle=300; {number of autorounded points per cycle} 370@!gf_buf_size=800; {size of the output buffer, must be a multiple of 8} 371@!file_name_size=40; {file names shouldn't be longer than this} 372@!pool_name='MFbases:MF.POOL '; 373 {string of length |file_name_size|; tells where the string pool appears} 374@.MFbases@> 375@!path_size=300; {maximum number of knots between breakpoints of a path} 376@!bistack_size=785; {size of stack for bisection algorithms; 377 should probably be left at this value} 378@!header_size=100; {maximum number of \.{TFM} header words, times~4} 379@!lig_table_size=5000; {maximum number of ligature/kern steps, must be 380 at least 255 and at most 32510} 381@!max_kerns=500; {maximum number of distinct kern amounts} 382@!max_font_dimen=50; {maximum number of \&{fontdimen} parameters} 383 384@ Like the preceding parameters, the following quantities can be changed 385at compile time to extend or reduce \MF's capacity. But if they are changed, 386it is necessary to rerun the initialization program \.{INIMF} 387@.INIMF@> 388to generate new tables for the production \MF\ program. 389One can't simply make helter-skelter changes to the following constants, 390since certain rather complex initialization 391numbers are computed from them. They are defined here using 392\.{WEB} macros, instead of being put into \PASCAL's |const| list, in order to 393emphasize this distinction. 394 395@d mem_min=0 {smallest index in the |mem| array, must not be less 396 than |min_halfword|} 397@d mem_top==30000 {largest index in the |mem| array dumped by \.{INIMF}; 398 must be substantially larger than |mem_min| 399 and not greater than |mem_max|} 400@d hash_size=2100 {maximum number of symbolic tokens, 401 must be less than |max_halfword-3*param_size|} 402@d hash_prime=1777 {a prime number equal to about 85\pct! of |hash_size|} 403@d max_in_open=6 {maximum number of input files and error insertions that 404 can be going on simultaneously} 405@d param_size=150 {maximum number of simultaneous macro parameters} 406@^system dependencies@> 407 408@ In case somebody has inadvertently made bad settings of the ``constants,'' 409\MF\ checks them using a global variable called |bad|. 410 411This is the first of many sections of \MF\ where global variables are 412defined. 413 414@<Glob...@>= 415@!bad:integer; {is some ``constant'' wrong?} 416 417@ Later on we will say `\ignorespaces|if mem_max>=max_halfword then bad:=10|', 418or something similar. (We can't do that until |max_halfword| has been defined.) 419 420@<Check the ``constant'' values for consistency@>= 421bad:=0; 422if (half_error_line<30)or(half_error_line>error_line-15) then bad:=1; 423if max_print_line<60 then bad:=2; 424if gf_buf_size mod 8<>0 then bad:=3; 425if mem_min+1100>mem_top then bad:=4; 426if hash_prime>hash_size then bad:=5; 427if header_size mod 4 <> 0 then bad:=6; 428if(lig_table_size<255)or(lig_table_size>32510)then bad:=7; 429 430@ Labels are given symbolic names by the following definitions, so that 431occasional |goto| statements will be meaningful. We insert the label 432`|exit|' just before the `\ignorespaces|end|\unskip' of a procedure in 433which we have used the `|return|' statement defined below; the label 434`|restart|' is occasionally used at the very beginning of a procedure; and 435the label `|reswitch|' is occasionally used just prior to a |case| 436statement in which some cases change the conditions and we wish to branch 437to the newly applicable case. Loops that are set up with the |loop| 438construction defined below are commonly exited by going to `|done|' or to 439`|found|' or to `|not_found|', and they are sometimes repeated by going to 440`|continue|'. If two or more parts of a subroutine start differently but 441end up the same, the shared code may be gathered together at 442`|common_ending|'. 443 444Incidentally, this program never declares a label that isn't actually used, 445because some fussy \PASCAL\ compilers will complain about redundant labels. 446 447@d exit=10 {go here to leave a procedure} 448@d restart=20 {go here to start a procedure again} 449@d reswitch=21 {go here to start a case statement again} 450@d continue=22 {go here to resume a loop} 451@d done=30 {go here to exit a loop} 452@d done1=31 {like |done|, when there is more than one loop} 453@d done2=32 {for exiting the second loop in a long block} 454@d done3=33 {for exiting the third loop in a very long block} 455@d done4=34 {for exiting the fourth loop in an extremely long block} 456@d done5=35 {for exiting the fifth loop in an immense block} 457@d done6=36 {for exiting the sixth loop in a block} 458@d found=40 {go here when you've found it} 459@d found1=41 {like |found|, when there's more than one per routine} 460@d found2=42 {like |found|, when there's more than two per routine} 461@d not_found=45 {go here when you've found nothing} 462@d common_ending=50 {go here when you want to merge with another branch} 463 464@ Here are some macros for common programming idioms. 465 466@d incr(#) == #:=#+1 {increase a variable by unity} 467@d decr(#) == #:=#-1 {decrease a variable by unity} 468@d negate(#) == #:=-# {change the sign of a variable} 469@d double(#) == #:=#+# {multiply a variable by two} 470@d loop == @+ while true do@+ {repeat over and over until a |goto| happens} 471@f loop == xclause 472 {\.{WEB}'s |xclause| acts like `\ignorespaces|while true do|\unskip'} 473@d do_nothing == {empty statement} 474@d return == goto exit {terminate a procedure call} 475@f return == nil {\.{WEB} will henceforth say |return| instead of \\{return}} 476 477@* \[2] The character set. 478In order to make \MF\ readily portable to a wide variety of 479computers, all of its input text is converted to an internal eight-bit 480code that includes standard ASCII, the ``American Standard Code for 481Information Interchange.'' This conversion is done immediately when each 482character is read in. Conversely, characters are converted from ASCII to 483the user's external representation just before they are output to a 484text file. 485@^ASCII code@> 486 487Such an internal code is relevant to users of \MF\ only with respect to 488the \&{char} and \&{ASCII} operations, and the comparison of strings. 489 490@ Characters of text that have been converted to \MF's internal form 491are said to be of type |ASCII_code|, which is a subrange of the integers. 492 493@<Types...@>= 494@!ASCII_code=0..255; {eight-bit numbers} 495 496@ The original \PASCAL\ compiler was designed in the late 60s, when six-bit 497character sets were common, so it did not make provision for lowercase 498letters. Nowadays, of course, we need to deal with both capital and small 499letters in a convenient way, especially in a program for font design; 500so the present specification of \MF\ has been written under the assumption 501that the \PASCAL\ compiler and run-time system permit the use of text files 502with more than 64 distinguishable characters. More precisely, we assume that 503the character set contains at least the letters and symbols associated 504with ASCII codes @'40 through @'176; all of these characters are now 505available on most computer terminals. 506 507Since we are dealing with more characters than were present in the first 508\PASCAL\ compilers, we have to decide what to call the associated data 509type. Some \PASCAL s use the original name |char| for the 510characters in text files, even though there now are more than 64 such 511characters, while other \PASCAL s consider |char| to be a 64-element 512subrange of a larger data type that has some other name. 513 514In order to accommodate this difference, we shall use the name |text_char| 515to stand for the data type of the characters that are converted to and 516from |ASCII_code| when they are input and output. We shall also assume 517that |text_char| consists of the elements |chr(first_text_char)| through 518|chr(last_text_char)|, inclusive. The following definitions should be 519adjusted if necessary. 520@^system dependencies@> 521 522@d text_char == char {the data type of characters in text files} 523@d first_text_char=0 {ordinal number of the smallest element of |text_char|} 524@d last_text_char=255 {ordinal number of the largest element of |text_char|} 525 526@<Local variables for init...@>= 527@!i:integer; 528 529@ The \MF\ processor converts between ASCII code and 530the user's external character set by means of arrays |xord| and |xchr| 531that are analogous to \PASCAL's |ord| and |chr| functions. 532 533@<Glob...@>= 534@!xord: array [text_char] of ASCII_code; 535 {specifies conversion of input characters} 536@!xchr: array [ASCII_code] of text_char; 537 {specifies conversion of output characters} 538 539@ Since we are assuming that our \PASCAL\ system is able to read and 540write the visible characters of standard ASCII (although not 541necessarily using the ASCII codes to represent them), the following 542assignment statements initialize the standard part of the |xchr| array 543properly, without needing any system-dependent changes. On the other 544hand, it is possible to implement \MF\ with less complete character 545sets, and in such cases it will be necessary to change something here. 546@^system dependencies@> 547 548@<Set init...@>= 549xchr[@'40]:=' '; 550xchr[@'41]:='!'; 551xchr[@'42]:='"'; 552xchr[@'43]:='#'; 553xchr[@'44]:='$'; 554xchr[@'45]:='%'; 555xchr[@'46]:='&'; 556xchr[@'47]:='''';@/ 557xchr[@'50]:='('; 558xchr[@'51]:=')'; 559xchr[@'52]:='*'; 560xchr[@'53]:='+'; 561xchr[@'54]:=','; 562xchr[@'55]:='-'; 563xchr[@'56]:='.'; 564xchr[@'57]:='/';@/ 565xchr[@'60]:='0'; 566xchr[@'61]:='1'; 567xchr[@'62]:='2'; 568xchr[@'63]:='3'; 569xchr[@'64]:='4'; 570xchr[@'65]:='5'; 571xchr[@'66]:='6'; 572xchr[@'67]:='7';@/ 573xchr[@'70]:='8'; 574xchr[@'71]:='9'; 575xchr[@'72]:=':'; 576xchr[@'73]:=';'; 577xchr[@'74]:='<'; 578xchr[@'75]:='='; 579xchr[@'76]:='>'; 580xchr[@'77]:='?';@/ 581xchr[@'100]:='@@'; 582xchr[@'101]:='A'; 583xchr[@'102]:='B'; 584xchr[@'103]:='C'; 585xchr[@'104]:='D'; 586xchr[@'105]:='E'; 587xchr[@'106]:='F'; 588xchr[@'107]:='G';@/ 589xchr[@'110]:='H'; 590xchr[@'111]:='I'; 591xchr[@'112]:='J'; 592xchr[@'113]:='K'; 593xchr[@'114]:='L'; 594xchr[@'115]:='M'; 595xchr[@'116]:='N'; 596xchr[@'117]:='O';@/ 597xchr[@'120]:='P'; 598xchr[@'121]:='Q'; 599xchr[@'122]:='R'; 600xchr[@'123]:='S'; 601xchr[@'124]:='T'; 602xchr[@'125]:='U'; 603xchr[@'126]:='V'; 604xchr[@'127]:='W';@/ 605xchr[@'130]:='X'; 606xchr[@'131]:='Y'; 607xchr[@'132]:='Z'; 608xchr[@'133]:='['; 609xchr[@'134]:='\'; 610xchr[@'135]:=']'; 611xchr[@'136]:='^'; 612xchr[@'137]:='_';@/ 613xchr[@'140]:='`'; 614xchr[@'141]:='a'; 615xchr[@'142]:='b'; 616xchr[@'143]:='c'; 617xchr[@'144]:='d'; 618xchr[@'145]:='e'; 619xchr[@'146]:='f'; 620xchr[@'147]:='g';@/ 621xchr[@'150]:='h'; 622xchr[@'151]:='i'; 623xchr[@'152]:='j'; 624xchr[@'153]:='k'; 625xchr[@'154]:='l'; 626xchr[@'155]:='m'; 627xchr[@'156]:='n'; 628xchr[@'157]:='o';@/ 629xchr[@'160]:='p'; 630xchr[@'161]:='q'; 631xchr[@'162]:='r'; 632xchr[@'163]:='s'; 633xchr[@'164]:='t'; 634xchr[@'165]:='u'; 635xchr[@'166]:='v'; 636xchr[@'167]:='w';@/ 637xchr[@'170]:='x'; 638xchr[@'171]:='y'; 639xchr[@'172]:='z'; 640xchr[@'173]:='{'; 641xchr[@'174]:='|'; 642xchr[@'175]:='}'; 643xchr[@'176]:='~';@/ 644 645@ The ASCII code is ``standard'' only to a certain extent, since many 646computer installations have found it advantageous to have ready access 647to more than 94 printing characters. If \MF\ is being used 648on a garden-variety \PASCAL\ for which only standard ASCII 649codes will appear in the input and output files, it doesn't really matter 650what codes are specified in |xchr[0..@'37]|, but the safest policy is to 651blank everything out by using the code shown below. 652 653However, other settings of |xchr| will make \MF\ more friendly on 654computers that have an extended character set, so that users can type things 655like `\.^^Z' instead of `\.{<>}'. 656People with extended character sets can 657assign codes arbitrarily, giving an |xchr| equivalent to whatever 658characters the users of \MF\ are allowed to have in their input files. 659Appropriate changes to \MF's |char_class| table should then be made. 660(Unlike \TeX, each installation of \MF\ has a fixed assignment of category 661codes, called the |char_class|.) Such changes make portability of programs 662more difficult, so they should be introduced cautiously if at all. 663@^character set dependencies@> 664@^system dependencies@> 665 666@<Set init...@>= 667for i:=0 to @'37 do xchr[i]:=' '; 668for i:=@'177 to @'377 do xchr[i]:=' '; 669 670@ The following system-independent code makes the |xord| array contain a 671suitable inverse to the information in |xchr|. Note that if |xchr[i]=xchr[j]| 672where |i<j<@'177|, the value of |xord[xchr[i]]| will turn out to be 673|j| or more; hence, standard ASCII code numbers will be used instead of 674codes below @'40 in case there is a coincidence. 675 676@<Set init...@>= 677for i:=first_text_char to last_text_char do xord[chr(i)]:=@'177; 678for i:=@'200 to @'377 do xord[xchr[i]]:=i; 679for i:=0 to @'176 do xord[xchr[i]]:=i; 680 681@* \[3] Input and output. 682The bane of portability is the fact that different operating systems treat 683input and output quite differently, perhaps because computer scientists 684have not given sufficient attention to this problem. People have felt somehow 685that input and output are not part of ``real'' programming. Well, it is true 686that some kinds of programming are more fun than others. With existing 687input/output conventions being so diverse and so messy, the only sources of 688joy in such parts of the code are the rare occasions when one can find a 689way to make the program a little less bad than it might have been. We have 690two choices, either to attack I/O now and get it over with, or to postpone 691I/O until near the end. Neither prospect is very attractive, so let's 692get it over with. 693 694The basic operations we need to do are (1)~inputting and outputting of 695text, to or from a file or the user's terminal; (2)~inputting and 696outputting of eight-bit bytes, to or from a file; (3)~instructing the 697operating system to initiate (``open'') or to terminate (``close'') input or 698output from a specified file; (4)~testing whether the end of an input 699file has been reached; (5)~display of bits on the user's screen. 700The bit-display operation will be discussed in a later section; we shall 701deal here only with more traditional kinds of I/O. 702 703\MF\ needs to deal with two kinds of files. 704We shall use the term |alpha_file| for a file that contains textual data, 705and the term |byte_file| for a file that contains eight-bit binary information. 706These two types turn out to be the same on many computers, but 707sometimes there is a significant distinction, so we shall be careful to 708distinguish between them. Standard protocols for transferring 709such files from computer to computer, via high-speed networks, are 710now becoming available to more and more communities of users. 711 712The program actually makes use also of a third kind of file, called a 713|word_file|, when dumping and reloading base information for its own 714initialization. We shall define a word file later; but it will be possible 715for us to specify simple operations on word files before they are defined. 716 717@<Types...@>= 718@!eight_bits=0..255; {unsigned one-byte quantity} 719@!alpha_file=packed file of text_char; {files that contain textual data} 720@!byte_file=packed file of eight_bits; {files that contain binary data} 721 722@ Most of what we need to do with respect to input and output can be handled 723by the I/O facilities that are standard in \PASCAL, i.e., the routines 724called |get|, |put|, |eof|, and so on. But 725standard \PASCAL\ does not allow file variables to be associated with file 726names that are determined at run time, so it cannot be used to implement 727\MF; some sort of extension to \PASCAL's ordinary |reset| and |rewrite| 728is crucial for our purposes. We shall assume that |name_of_file| is a variable 729of an appropriate type such that the \PASCAL\ run-time system being used to 730implement \MF\ can open a file whose external name is specified by 731|name_of_file|. 732@^system dependencies@> 733 734@<Glob...@>= 735@!name_of_file:packed array[1..file_name_size] of char;@;@/ 736 {on some systems this may be a \&{record} variable} 737@!name_length:0..file_name_size;@/{this many characters are actually 738 relevant in |name_of_file| (the rest are blank)} 739 740@ The \ph\ compiler with which the present version of \MF\ was prepared has 741extended the rules of \PASCAL\ in a very convenient way. To open file~|f|, 742we can write 743$$\vbox{\halign{#\hfil\qquad&#\hfil\cr 744|reset(f,@t\\{name}@>,'/O')|&for input;\cr 745|rewrite(f,@t\\{name}@>,'/O')|&for output.\cr}}$$ 746The `\\{name}' parameter, which is of type `\ignorespaces|packed 747array[@t\<\\{any}>@>] of text_char|', stands for the name of 748the external file that is being opened for input or output. 749Blank spaces that might appear in \\{name} are ignored. 750 751The `\.{/O}' parameter tells the operating system not to issue its own 752error messages if something goes wrong. If a file of the specified name 753cannot be found, or if such a file cannot be opened for some other reason 754(e.g., someone may already be trying to write the same file), we will have 755|@!erstat(f)<>0| after an unsuccessful |reset| or |rewrite|. This allows 756\MF\ to undertake appropriate corrective action. 757@:PASCAL H}{\ph@> 758@^system dependencies@> 759 760\MF's file-opening procedures return |false| if no file identified by 761|name_of_file| could be opened. 762 763@d reset_OK(#)==erstat(#)=0 764@d rewrite_OK(#)==erstat(#)=0 765 766@p function a_open_in(var @!f:alpha_file):boolean; 767 {open a text file for input} 768begin reset(f,name_of_file,'/O'); a_open_in:=reset_OK(f); 769end; 770@# 771function a_open_out(var @!f:alpha_file):boolean; 772 {open a text file for output} 773begin rewrite(f,name_of_file,'/O'); a_open_out:=rewrite_OK(f); 774end; 775@# 776function b_open_out(var @!f:byte_file):boolean; 777 {open a binary file for output} 778begin rewrite(f,name_of_file,'/O'); b_open_out:=rewrite_OK(f); 779end; 780@# 781function w_open_in(var @!f:word_file):boolean; 782 {open a word file for input} 783begin reset(f,name_of_file,'/O'); w_open_in:=reset_OK(f); 784end; 785@# 786function w_open_out(var @!f:word_file):boolean; 787 {open a word file for output} 788begin rewrite(f,name_of_file,'/O'); w_open_out:=rewrite_OK(f); 789end; 790 791@ Files can be closed with the \ph\ routine `|close(f)|', which 792@:PASCAL H}{\ph@> 793@^system dependencies@> 794should be used when all input or output with respect to |f| has been completed. 795This makes |f| available to be opened again, if desired; and if |f| was used for 796output, the |close| operation makes the corresponding external file appear 797on the user's area, ready to be read. 798 799@p procedure a_close(var @!f:alpha_file); {close a text file} 800begin close(f); 801end; 802@# 803procedure b_close(var @!f:byte_file); {close a binary file} 804begin close(f); 805end; 806@# 807procedure w_close(var @!f:word_file); {close a word file} 808begin close(f); 809end; 810 811@ Binary input and output are done with \PASCAL's ordinary |get| and |put| 812procedures, so we don't have to make any other special arrangements for 813binary~I/O. Text output is also easy to do with standard \PASCAL\ routines. 814The treatment of text input is more difficult, however, because 815of the necessary translation to |ASCII_code| values. 816\MF's conventions should be efficient, and they should 817blend nicely with the user's operating environment. 818 819@ Input from text files is read one line at a time, using a routine called 820|input_ln|. This function is defined in terms of global variables called 821|buffer|, |first|, and |last| that will be described in detail later; for 822now, it suffices for us to know that |buffer| is an array of |ASCII_code| 823values, and that |first| and |last| are indices into this array 824representing the beginning and ending of a line of text. 825 826@<Glob...@>= 827@!buffer:array[0..buf_size] of ASCII_code; {lines of characters being read} 828@!first:0..buf_size; {the first unused position in |buffer|} 829@!last:0..buf_size; {end of the line just input to |buffer|} 830@!max_buf_stack:0..buf_size; {largest index used in |buffer|} 831 832@ The |input_ln| function brings the next line of input from the specified 833field into available positions of the buffer array and returns the value 834|true|, unless the file has already been entirely read, in which case it 835returns |false| and sets |last:=first|. In general, the |ASCII_code| 836numbers that represent the next line of the file are input into 837|buffer[first]|, |buffer[first+1]|, \dots, |buffer[last-1]|; and the 838global variable |last| is set equal to |first| plus the length of the 839line. Trailing blanks are removed from the line; thus, either |last=first| 840(in which case the line was entirely blank) or |buffer[last-1]<>" "|. 841@^inner loop@> 842 843An overflow error is given, however, if the normal actions of |input_ln| 844would make |last>=buf_size|; this is done so that other parts of \MF\ 845can safely look at the contents of |buffer[last+1]| without overstepping 846the bounds of the |buffer| array. Upon entry to |input_ln|, the condition 847|first<buf_size| will always hold, so that there is always room for an 848``empty'' line. 849 850The variable |max_buf_stack|, which is used to keep track of how large 851the |buf_size| parameter must be to accommodate the present job, is 852also kept up to date by |input_ln|. 853 854If the |bypass_eoln| parameter is |true|, |input_ln| will do a |get| 855before looking at the first character of the line; this skips over 856an |eoln| that was in |f^|. The procedure does not do a |get| when it 857reaches the end of the line; therefore it can be used to acquire input 858from the user's terminal as well as from ordinary text files. 859 860Standard \PASCAL\ says that a file should have |eoln| immediately 861before |eof|, but \MF\ needs only a weaker restriction: If |eof| 862occurs in the middle of a line, the system function |eoln| should return 863a |true| result (even though |f^| will be undefined). 864 865@p function input_ln(var @!f:alpha_file;@!bypass_eoln:boolean):boolean; 866 {inputs the next line or returns |false|} 867var @!last_nonblank:0..buf_size; {|last| with trailing blanks removed} 868begin if bypass_eoln then if not eof(f) then get(f); 869 {input the first character of the line into |f^|} 870last:=first; {cf.\ Matthew 19\thinspace:\thinspace30} 871if eof(f) then input_ln:=false 872else begin last_nonblank:=first; 873 while not eoln(f) do 874 begin if last>=max_buf_stack then 875 begin max_buf_stack:=last+1; 876 if max_buf_stack=buf_size then 877 @<Report overflow of the input buffer, and abort@>; 878 end; 879 buffer[last]:=xord[f^]; get(f); incr(last); 880 if buffer[last-1]<>" " then last_nonblank:=last; 881 end; 882 last:=last_nonblank; input_ln:=true; 883 end; 884end; 885 886@ The user's terminal acts essentially like other files of text, except 887that it is used both for input and for output. When the terminal is 888considered an input file, the file variable is called |term_in|, and when it 889is considered an output file the file variable is |term_out|. 890@^system dependencies@> 891 892@<Glob...@>= 893@!term_in:alpha_file; {the terminal as an input file} 894@!term_out:alpha_file; {the terminal as an output file} 895 896@ Here is how to open the terminal files 897in \ph. The `\.{/I}' switch suppresses the first |get|. 898@:PASCAL H}{\ph@> 899@^system dependencies@> 900 901@d t_open_in==reset(term_in,'TTY:','/O/I') {open the terminal for text input} 902@d t_open_out==rewrite(term_out,'TTY:','/O') 903 {open the terminal for text output} 904 905@ Sometimes it is necessary to synchronize the input/output mixture that 906happens on the user's terminal, and three system-dependent 907procedures are used for this 908purpose. The first of these, |update_terminal|, is called when we want 909to make sure that everything we have output to the terminal so far has 910actually left the computer's internal buffers and been sent. 911The second, |clear_terminal|, is called when we wish to cancel any 912input that the user may have typed ahead (since we are about to 913issue an unexpected error message). The third, |wake_up_terminal|, 914is supposed to revive the terminal if the user has disabled it by 915some instruction to the operating system. The following macros show how 916these operations can be specified in \ph: 917@:PASCAL H}{\ph@> 918@^system dependencies@> 919 920@d update_terminal == break(term_out) {empty the terminal output buffer} 921@d clear_terminal == break_in(term_in,true) {clear the terminal input buffer} 922@d wake_up_terminal == do_nothing {cancel the user's cancellation of output} 923 924@ We need a special routine to read the first line of \MF\ input from 925the user's terminal. This line is different because it is read before we 926have opened the transcript file; there is sort of a ``chicken and 927egg'' problem here. If the user types `\.{input cmr10}' on the first 928line, or if some macro invoked by that line does such an \.{input}, 929the transcript file will be named `\.{cmr10.log}'; but if no \.{input} 930commands are performed during the first line of terminal input, the transcript 931file will acquire its default name `\.{mfput.log}'. (The transcript file 932will not contain error messages generated by the first line before the 933first \.{input} command.) 934@.mfput@> 935 936The first line is even more special if we are lucky enough to have an operating 937system that treats \MF\ differently from a run-of-the-mill \PASCAL\ object 938program. It's nice to let the user start running a \MF\ job by typing 939a command line like `\.{MF cmr10}'; in such a case, \MF\ will operate 940as if the first line of input were `\.{cmr10}', i.e., the first line will 941consist of the remainder of the command line, after the part that invoked \MF. 942 943The first line is special also because it may be read before \MF\ has 944input a base file. In such cases, normal error messages cannot yet 945be given. The following code uses concepts that will be explained later. 946(If the \PASCAL\ compiler does not support non-local |@!goto|\unskip, the 947@^system dependencies@> 948statement `|goto final_end|' should be replaced by something that 949quietly terminates the program.) 950 951@<Report overflow of the input buffer, and abort@>= 952if base_ident=0 then 953 begin write_ln(term_out,'Buffer size exceeded!'); goto final_end; 954@.Buffer size exceeded@> 955 end 956else begin cur_input.loc_field:=first; cur_input.limit_field:=last-1; 957 overflow("buffer size",buf_size); 958@:METAFONT capacity exceeded buffer size}{\quad buffer size@> 959 end 960 961@ Different systems have different ways to get started. But regardless of 962what conventions are adopted, the routine that initializes the terminal 963should satisfy the following specifications: 964 965\yskip\textindent{1)}It should open file |term_in| for input from the 966 terminal. (The file |term_out| will already be open for output to the 967 terminal.) 968 969\textindent{2)}If the user has given a command line, this line should be 970 considered the first line of terminal input. Otherwise the 971 user should be prompted with `\.{**}', and the first line of input 972 should be whatever is typed in response. 973 974\textindent{3)}The first line of input, which might or might not be a 975 command line, should appear in locations |first| to |last-1| of the 976 |buffer| array. 977 978\textindent{4)}The global variable |loc| should be set so that the 979 character to be read next by \MF\ is in |buffer[loc]|. This 980 character should not be blank, and we should have |loc<last|. 981 982\yskip\noindent(It may be necessary to prompt the user several times 983before a non-blank line comes in. The prompt is `\.{**}' instead of the 984later `\.*' because the meaning is slightly different: `\.{input}' need 985not be typed immediately after~`\.{**}'.) 986 987@d loc==cur_input.loc_field {location of first unread character in |buffer|} 988 989@ The following program does the required initialization 990without retrieving a possible command line. 991It should be clear how to modify this routine to deal with command lines, 992if the system permits them. 993@^system dependencies@> 994 995@p function init_terminal:boolean; {gets the terminal input started} 996label exit; 997begin t_open_in; 998loop@+begin wake_up_terminal; write(term_out,'**'); update_terminal; 999@.**@> 1000 if not input_ln(term_in,true) then {this shouldn't happen} 1001 begin write_ln(term_out); 1002 write(term_out,'! End of file on the terminal... why?'); 1003@.End of file on the terminal@> 1004 init_terminal:=false; return; 1005 end; 1006 loc:=first; 1007 while (loc<last)and(buffer[loc]=" ") do incr(loc); 1008 if loc<last then 1009 begin init_terminal:=true; 1010 return; {return unless the line was all blank} 1011 end; 1012 write_ln(term_out,'Please type the name of your input file.'); 1013 end; 1014exit:end; 1015 1016@* \[4] String handling. 1017Symbolic token names and diagnostic messages are variable-length strings 1018of eight-bit characters. Since \PASCAL\ does not have a well-developed string 1019mechanism, \MF\ does all of its string processing by homegrown methods. 1020 1021Elaborate facilities for dynamic strings are not needed, so all of the 1022necessary operations can be handled with a simple data structure. 1023The array |str_pool| contains all of the (eight-bit) ASCII codes in all 1024of the strings, and the array |str_start| contains indices of the starting 1025points of each string. Strings are referred to by integer numbers, so that 1026string number |s| comprises the characters |str_pool[j]| for 1027|str_start[s]<=j<str_start[s+1]|. Additional integer variables 1028|pool_ptr| and |str_ptr| indicate the number of entries used so far 1029in |str_pool| and |str_start|, respectively; locations 1030|str_pool[pool_ptr]| and |str_start[str_ptr]| are 1031ready for the next string to be allocated. 1032 1033String numbers 0 to 255 are reserved for strings that correspond to single 1034ASCII characters. This is in accordance with the conventions of \.{WEB}, 1035@.WEB@> 1036which converts single-character strings into the ASCII code number of the 1037single character involved, while it converts other strings into integers 1038and builds a string pool file. Thus, when the string constant \.{"."} appears 1039in the program below, \.{WEB} converts it into the integer 46, which is the 1040ASCII code for a period, while \.{WEB} will convert a string like \.{"hello"} 1041into some integer greater than~255. String number 46 will presumably be the 1042single character `\..'\thinspace; but some ASCII codes have no standard visible 1043representation, and \MF\ may need to be able to print an arbitrary 1044ASCII character, so the first 256 strings are used to specify exactly what 1045should be printed for each of the 256 possibilities. 1046 1047Elements of the |str_pool| array must be ASCII codes that can actually be 1048printed; i.e., they must have an |xchr| equivalent in the local 1049character set. (This restriction applies only to preloaded strings, 1050not to those generated dynamically by the user.) 1051 1052Some \PASCAL\ compilers won't pack integers into a single byte unless the 1053integers lie in the range |-128..127|. To accommodate such systems 1054we access the string pool only via macros that can easily be redefined. 1055@^system dependencies@> 1056 1057@d si(#) == # {convert from |ASCII_code| to |packed_ASCII_code|} 1058@d so(#) == # {convert from |packed_ASCII_code| to |ASCII_code|} 1059 1060@<Types...@>= 1061@!pool_pointer = 0..pool_size; {for variables that point into |str_pool|} 1062@!str_number = 0..max_strings; {for variables that point into |str_start|} 1063@!packed_ASCII_code = 0..255; {elements of |str_pool| array} 1064 1065@ @<Glob...@>= 1066@!str_pool:packed array[pool_pointer] of packed_ASCII_code; {the characters} 1067@!str_start : array[str_number] of pool_pointer; {the starting pointers} 1068@!pool_ptr : pool_pointer; {first unused position in |str_pool|} 1069@!str_ptr : str_number; {number of the current string being created} 1070@!init_pool_ptr : pool_pointer; {the starting value of |pool_ptr|} 1071@!init_str_ptr : str_number; {the starting value of |str_ptr|} 1072@!max_pool_ptr : pool_pointer; {the maximum so far of |pool_ptr|} 1073@!max_str_ptr : str_number; {the maximum so far of |str_ptr|} 1074 1075@ Several of the elementary string operations are performed using \.{WEB} 1076macros instead of \PASCAL\ procedures, because many of the 1077operations are done quite frequently and we want to avoid the 1078overhead of procedure calls. For example, here is 1079a simple macro that computes the length of a string. 1080@.WEB@> 1081 1082@d length(#)==(str_start[#+1]-str_start[#]) {the number of characters 1083 in string number \#} 1084 1085@ The length of the current string is called |cur_length|: 1086 1087@d cur_length == (pool_ptr - str_start[str_ptr]) 1088 1089@ Strings are created by appending character codes to |str_pool|. 1090The |append_char| macro, defined here, does not check to see if the 1091value of |pool_ptr| has gotten too high; this test is supposed to be 1092made before |append_char| is used. 1093 1094To test if there is room to append |l| more characters to |str_pool|, 1095we shall write |str_room(l)|, which aborts \MF\ and gives an 1096apologetic error message if there isn't enough room. 1097 1098@d append_char(#) == {put |ASCII_code| \# at the end of |str_pool|} 1099begin str_pool[pool_ptr]:=si(#); incr(pool_ptr); 1100end 1101@d str_room(#) == {make sure that the pool hasn't overflowed} 1102 begin if pool_ptr+# > max_pool_ptr then 1103 begin if pool_ptr+# > pool_size then 1104 overflow("pool size",pool_size-init_pool_ptr); 1105@:METAFONT capacity exceeded pool size}{\quad pool size@> 1106 max_pool_ptr:=pool_ptr+#; 1107 end; 1108 end 1109 1110@ \MF's string expressions are implemented in a brute-force way: Every 1111new string or substring that is needed is simply copied into the string pool. 1112 1113Such a scheme can be justified because string expressions aren't a big 1114deal in \MF\ applications; strings rarely need to be saved from one 1115statement to the next. But it would waste space needlessly if we didn't 1116try to reclaim the space of strings that are going to be used only once. 1117 1118Therefore a simple reference count mechanism is provided: If there are 1119@^reference counts@> 1120no references to a certain string from elsewhere in the program, and 1121if there are no references to any strings created subsequent to it, 1122then the string space will be reclaimed. 1123 1124The number of references to string number |s| will be |str_ref[s]|. The 1125special value |str_ref[s]=max_str_ref=127| is used to denote an unknown 1126positive number of references; such strings will never be recycled. If 1127a string is ever referred to more than 126 times, simultaneously, we 1128put it in this category. Hence a single byte suffices to store each |str_ref|. 1129 1130@d max_str_ref=127 {``infinite'' number of references} 1131@d add_str_ref(#)==begin if str_ref[#]<max_str_ref then incr(str_ref[#]); 1132 end 1133 1134@<Glob...@>= 1135@!str_ref:array[str_number] of 0..max_str_ref; 1136 1137@ Here's what we do when a string reference disappears: 1138 1139@d delete_str_ref(#)== begin if str_ref[#]<max_str_ref then 1140 if str_ref[#]>1 then decr(str_ref[#])@+else flush_string(#); 1141 end 1142 1143@<Declare the procedure called |flush_string|@>= 1144procedure flush_string(@!s:str_number); 1145begin if s<str_ptr-1 then str_ref[s]:=0 1146else repeat decr(str_ptr); 1147 until str_ref[str_ptr-1]<>0; 1148pool_ptr:=str_start[str_ptr]; 1149end; 1150 1151@ Once a sequence of characters has been appended to |str_pool|, it 1152officially becomes a string when the function |make_string| is called. 1153This function returns the identification number of the new string as its 1154value. 1155 1156@p function make_string : str_number; {current string enters the pool} 1157begin if str_ptr=max_str_ptr then 1158 begin if str_ptr=max_strings then 1159 overflow("number of strings",max_strings-init_str_ptr); 1160@:METAFONT capacity exceeded number of strings}{\quad number of strings@> 1161 incr(max_str_ptr); 1162 end; 1163str_ref[str_ptr]:=1; incr(str_ptr); str_start[str_ptr]:=pool_ptr; 1164make_string:=str_ptr-1; 1165end; 1166 1167@ The following subroutine compares string |s| with another string of the 1168same length that appears in |buffer| starting at position |k|; 1169the result is |true| if and only if the strings are equal. 1170 1171@p function str_eq_buf(@!s:str_number;@!k:integer):boolean; 1172 {test equality of strings} 1173label not_found; {loop exit} 1174var @!j: pool_pointer; {running index} 1175@!result: boolean; {result of comparison} 1176begin j:=str_start[s]; 1177while j<str_start[s+1] do 1178 begin if so(str_pool[j])<>buffer[k] then 1179 begin result:=false; goto not_found; 1180 end; 1181 incr(j); incr(k); 1182 end; 1183result:=true; 1184not_found: str_eq_buf:=result; 1185end; 1186 1187@ Here is a similar routine, but it compares two strings in the string pool, 1188and it does not assume that they have the same length. If the first string 1189is lexicographically greater than, less than, or equal to the second, 1190the result is respectively positive, negative, or zero. 1191 1192@p function str_vs_str(@!s,@!t:str_number):integer; 1193 {test equality of strings} 1194label exit; 1195var @!j,@!k: pool_pointer; {running indices} 1196@!ls,@!lt:integer; {lengths} 1197@!l:integer; {length remaining to test} 1198begin ls:=length(s); lt:=length(t); 1199if ls<=lt then l:=ls@+else l:=lt; 1200j:=str_start[s]; k:=str_start[t]; 1201while l>0 do 1202 begin if str_pool[j]<>str_pool[k] then 1203 begin str_vs_str:=str_pool[j]-str_pool[k]; return; 1204 end; 1205 incr(j); incr(k); decr(l); 1206 end; 1207str_vs_str:=ls-lt; 1208exit:end; 1209 1210@ The initial values of |str_pool|, |str_start|, |pool_ptr|, 1211and |str_ptr| are computed by the \.{INIMF} program, based in part 1212on the information that \.{WEB} has output while processing \MF. 1213@.INIMF@> 1214@^string pool@> 1215 1216@p @!init function get_strings_started:boolean; {initializes the string pool, 1217 but returns |false| if something goes wrong} 1218label done,exit; 1219var @!k,@!l:0..255; {small indices or counters} 1220@!m,@!n:text_char; {characters input from |pool_file|} 1221@!g:str_number; {garbage} 1222@!a:integer; {accumulator for check sum} 1223@!c:boolean; {check sum has been checked} 1224begin pool_ptr:=0; str_ptr:=0; max_pool_ptr:=0; max_str_ptr:=0; str_start[0]:=0; 1225@<Make the first 256 strings@>; 1226@<Read the other strings from the \.{MF.POOL} file and return |true|, 1227 or give an error message and return |false|@>; 1228exit:end; 1229tini 1230 1231@ @d app_lc_hex(#)==l:=#; 1232 if l<10 then append_char(l+"0")@+else append_char(l-10+"a") 1233 1234@<Make the first 256...@>= 1235for k:=0 to 255 do 1236 begin if (@<Character |k| cannot be printed@>) then 1237 begin append_char("^"); append_char("^"); 1238 if k<@'100 then append_char(k+@'100) 1239 else if k<@'200 then append_char(k-@'100) 1240 else begin app_lc_hex(k div 16); app_lc_hex(k mod 16); 1241 end; 1242 end 1243 else append_char(k); 1244 g:=make_string; str_ref[g]:=max_str_ref; 1245 end 1246 1247@ The first 128 strings will contain 95 standard ASCII characters, and the 1248other 33 characters will be printed in three-symbol form like `\.{\^\^A}' 1249unless a system-dependent change is made here. Installations that have 1250an extended character set, where for example |xchr[@'32]=@t\.{\'^^Z\'}@>|, 1251would like string @'32 to be the single character @'32 instead of the 1252three characters @'136, @'136, @'132 (\.{\^\^Z}). On the other hand, 1253even people with an extended character set will want to represent string 1254@'15 by \.{\^\^M}, since @'15 is ASCII's ``carriage return'' code; the idea is 1255to produce visible strings instead of tabs or line-feeds or carriage-returns 1256or bell-rings or characters that are treated anomalously in text files. 1257 1258Unprintable characters of codes 128--255 are, similarly, rendered 1259\.{\^\^80}--\.{\^\^ff}. 1260 1261The boolean expression defined here should be |true| unless \MF\ internal 1262code number~|k| corresponds to a non-troublesome visible symbol in the 1263local character set. 1264If character |k| cannot be printed, and |k<@'200|, then character |k+@'100| or 1265|k-@'100| must be printable; moreover, ASCII codes 1266|[@'60..@'71, @'136, @'141..@'146]| 1267must be printable. 1268@^character set dependencies@> 1269@^system dependencies@> 1270 1271@<Character |k| cannot be printed@>= 1272 (k<" ")or(k>"~") 1273 1274@ When the \.{WEB} system program called \.{TANGLE} processes the \.{MF.WEB} 1275description that you are now reading, it outputs the \PASCAL\ program 1276\.{MF.PAS} and also a string pool file called \.{MF.POOL}. The \.{INIMF} 1277@.WEB@>@.INIMF@> 1278program reads the latter file, where each string appears as a two-digit decimal 1279length followed by the string itself, and the information is recorded in 1280\MF's string memory. 1281 1282@<Glob...@>= 1283@!init @!pool_file:alpha_file; {the string-pool file output by \.{TANGLE}} 1284tini 1285 1286@ @d bad_pool(#)==begin wake_up_terminal; write_ln(term_out,#); 1287 a_close(pool_file); get_strings_started:=false; return; 1288 end 1289@<Read the other strings...@>= 1290name_of_file:=pool_name; {we needn't set |name_length|} 1291if a_open_in(pool_file) then 1292 begin c:=false; 1293 repeat @<Read one string, but return |false| if the 1294 string memory space is getting too tight for comfort@>; 1295 until c; 1296 a_close(pool_file); get_strings_started:=true; 1297 end 1298else bad_pool('! I can''t read MF.POOL.') 1299@.I can't read MF.POOL@> 1300 1301@ @<Read one string...@>= 1302begin if eof(pool_file) then bad_pool('! MF.POOL has no check sum.'); 1303@.MF.POOL has no check sum@> 1304read(pool_file,m,n); {read two digits of string length} 1305if m='*' then @<Check the pool check sum@> 1306else begin if (xord[m]<"0")or(xord[m]>"9")or@| 1307 (xord[n]<"0")or(xord[n]>"9") then 1308 bad_pool('! MF.POOL line doesn''t begin with two digits.'); 1309@.MF.POOL line doesn't...@> 1310 l:=xord[m]*10+xord[n]-"0"*11; {compute the length} 1311 if pool_ptr+l+string_vacancies>pool_size then 1312 bad_pool('! You have to increase POOLSIZE.'); 1313@.You have to increase POOLSIZE@> 1314 for k:=1 to l do 1315 begin if eoln(pool_file) then m:=' '@+else read(pool_file,m); 1316 append_char(xord[m]); 1317 end; 1318 read_ln(pool_file); g:=make_string; str_ref[g]:=max_str_ref; 1319 end; 1320end 1321 1322@ The \.{WEB} operation \.{@@\$} denotes the value that should be at the 1323end of this \.{MF.POOL} file; any other value means that the wrong pool 1324file has been loaded. 1325@^check sum@> 1326 1327@<Check the pool check sum@>= 1328begin a:=0; k:=1; 1329loop@+ begin if (xord[n]<"0")or(xord[n]>"9") then 1330 bad_pool('! MF.POOL check sum doesn''t have nine digits.'); 1331@.MF.POOL check sum...@> 1332 a:=10*a+xord[n]-"0"; 1333 if k=9 then goto done; 1334 incr(k); read(pool_file,n); 1335 end; 1336done: if a<>@$ then bad_pool('! MF.POOL doesn''t match; TANGLE me again.'); 1337@.MF.POOL doesn't match@> 1338c:=true; 1339end 1340 1341@* \[5] On-line and off-line printing. 1342Messages that are sent to a user's terminal and to the transcript-log file 1343are produced by several `|print|' procedures. These procedures will 1344direct their output to a variety of places, based on the setting of 1345the global variable |selector|, which has the following possible 1346values: 1347 1348\yskip 1349\hang |term_and_log|, the normal setting, prints on the terminal and on the 1350 transcript file. 1351 1352\hang |log_only|, prints only on the transcript file. 1353 1354\hang |term_only|, prints only on the terminal. 1355 1356\hang |no_print|, doesn't print at all. This is used only in rare cases 1357 before the transcript file is open. 1358 1359\hang |pseudo|, puts output into a cyclic buffer that is used 1360 by the |show_context| routine; when we get to that routine we shall discuss 1361 the reasoning behind this curious mode. 1362 1363\hang |new_string|, appends the output to the current string in the 1364 string pool. 1365 1366\yskip 1367\noindent The symbolic names `|term_and_log|', etc., have been assigned 1368numeric codes that satisfy the convenient relations |no_print+1=term_only|, 1369|no_print+2=log_only|, |term_only+2=log_only+1=term_and_log|. 1370 1371Three additional global variables, |tally| and |term_offset| and 1372|file_offset|, record the number of characters that have been printed 1373since they were most recently cleared to zero. We use |tally| to record 1374the length of (possibly very long) stretches of printing; |term_offset| 1375and |file_offset|, on the other hand, keep track of how many characters 1376have appeared so far on the current line that has been output to the 1377terminal or to the transcript file, respectively. 1378 1379@d no_print=0 {|selector| setting that makes data disappear} 1380@d term_only=1 {printing is destined for the terminal only} 1381@d log_only=2 {printing is destined for the transcript file only} 1382@d term_and_log=3 {normal |selector| setting} 1383@d pseudo=4 {special |selector| setting for |show_context|} 1384@d new_string=5 {printing is deflected to the string pool} 1385@d max_selector=5 {highest selector setting} 1386 1387@<Glob...@>= 1388@!log_file : alpha_file; {transcript of \MF\ session} 1389@!selector : 0..max_selector; {where to print a message} 1390@!dig : array[0..22] of 0..15; {digits in a number being output} 1391@!tally : integer; {the number of characters recently printed} 1392@!term_offset : 0..max_print_line; 1393 {the number of characters on the current terminal line} 1394@!file_offset : 0..max_print_line; 1395 {the number of characters on the current file line} 1396@!trick_buf:array[0..error_line] of ASCII_code; {circular buffer for 1397 pseudoprinting} 1398@!trick_count: integer; {threshold for pseudoprinting, explained later} 1399@!first_count: integer; {another variable for pseudoprinting} 1400 1401@ @<Initialize the output routines@>= 1402selector:=term_only; tally:=0; term_offset:=0; file_offset:=0; 1403 1404@ Macro abbreviations for output to the terminal and to the log file are 1405defined here for convenience. Some systems need special conventions 1406for terminal output, and it is possible to adhere to those conventions 1407by changing |wterm|, |wterm_ln|, and |wterm_cr| here. 1408@^system dependencies@> 1409 1410@d wterm(#)==write(term_out,#) 1411@d wterm_ln(#)==write_ln(term_out,#) 1412@d wterm_cr==write_ln(term_out) 1413@d wlog(#)==write(log_file,#) 1414@d wlog_ln(#)==write_ln(log_file,#) 1415@d wlog_cr==write_ln(log_file) 1416 1417@ To end a line of text output, we call |print_ln|. 1418 1419@<Basic print...@>= 1420procedure print_ln; {prints an end-of-line} 1421begin case selector of 1422term_and_log: begin wterm_cr; wlog_cr; 1423 term_offset:=0; file_offset:=0; 1424 end; 1425log_only: begin wlog_cr; file_offset:=0; 1426 end; 1427term_only: begin wterm_cr; term_offset:=0; 1428 end; 1429no_print,pseudo,new_string: do_nothing; 1430end; {there are no other cases} 1431end; {note that |tally| is not affected} 1432 1433@ The |print_char| procedure sends one character to the desired destination, 1434using the |xchr| array to map it into an external character compatible with 1435|input_ln|. All printing comes through |print_ln| or |print_char|. 1436 1437@<Basic printing...@>= 1438procedure print_char(@!s:ASCII_code); {prints a single character} 1439begin case selector of 1440term_and_log: begin wterm(xchr[s]); wlog(xchr[s]); 1441 incr(term_offset); incr(file_offset); 1442 if term_offset=max_print_line then 1443 begin wterm_cr; term_offset:=0; 1444 end; 1445 if file_offset=max_print_line then 1446 begin wlog_cr; file_offset:=0; 1447 end; 1448 end; 1449log_only: begin wlog(xchr[s]); incr(file_offset); 1450 if file_offset=max_print_line then print_ln; 1451 end; 1452term_only: begin wterm(xchr[s]); incr(term_offset); 1453 if term_offset=max_print_line then print_ln; 1454 end; 1455no_print: do_nothing; 1456pseudo: if tally<trick_count then trick_buf[tally mod error_line]:=s; 1457new_string: begin if pool_ptr<pool_size then append_char(s); 1458 end; {we drop characters if the string space is full} 1459end; {there are no other cases} 1460incr(tally); 1461end; 1462 1463@ An entire string is output by calling |print|. Note that if we are outputting 1464the single standard ASCII character \.c, we could call |print("c")|, since 1465|"c"=99| is the number of a single-character string, as explained above. But 1466|print_char("c")| is quicker, so \MF\ goes directly to the |print_char| 1467routine when it knows that this is safe. (The present implementation 1468assumes that it is always safe to print a visible ASCII character.) 1469@^system dependencies@> 1470 1471@<Basic print...@>= 1472procedure print(@!s:integer); {prints string |s|} 1473var @!j:pool_pointer; {current character code position} 1474begin if (s<0)or(s>=str_ptr) then s:="???"; {this can't happen} 1475@.???@> 1476if (s<256)and(selector>pseudo) then print_char(s) 1477else begin j:=str_start[s]; 1478 while j<str_start[s+1] do 1479 begin print_char(so(str_pool[j])); incr(j); 1480 end; 1481 end; 1482end; 1483 1484@ Sometimes it's necessary to print a string whose characters 1485may not be visible ASCII codes. In that case |slow_print| is used. 1486 1487@<Basic print...@>= 1488procedure slow_print(@!s:integer); {prints string |s|} 1489var @!j:pool_pointer; {current character code position} 1490begin if (s<0)or(s>=str_ptr) then s:="???"; {this can't happen} 1491@.???@> 1492if (s<256)and(selector>pseudo) then print_char(s) 1493else begin j:=str_start[s]; 1494 while j<str_start[s+1] do 1495 begin print(so(str_pool[j])); incr(j); 1496 end; 1497 end; 1498end; 1499 1500@ Here is the very first thing that \MF\ prints: a headline that identifies 1501the version number and base name. The |term_offset| variable is temporarily 1502incorrect, but the discrepancy is not serious since we assume that the banner 1503and base identifier together will occupy at most |max_print_line| 1504character positions. 1505 1506@<Initialize the output...@>= 1507wterm(banner); 1508if base_ident=0 then wterm_ln(' (no base preloaded)') 1509else begin slow_print(base_ident); print_ln; 1510 end; 1511update_terminal; 1512 1513@ The procedure |print_nl| is like |print|, but it makes sure that the 1514string appears at the beginning of a new line. 1515 1516@<Basic print...@>= 1517procedure print_nl(@!s:str_number); {prints string |s| at beginning of line} 1518begin if ((term_offset>0)and(odd(selector)))or@| 1519 ((file_offset>0)and(selector>=log_only)) then print_ln; 1520print(s); 1521end; 1522 1523@ An array of digits in the range |0..9| is printed by |print_the_digs|. 1524 1525@<Basic print...@>= 1526procedure print_the_digs(@!k:eight_bits); 1527 {prints |dig[k-1]|$\,\ldots\,$|dig[0]|} 1528begin while k>0 do 1529 begin decr(k); print_char("0"+dig[k]); 1530 end; 1531end; 1532 1533@ The following procedure, which prints out the decimal representation of a 1534given integer |n|, has been written carefully so that it works properly 1535if |n=0| or if |(-n)| would cause overflow. It does not apply |mod| or |div| 1536to negative arguments, since such operations are not implemented consistently 1537by all \PASCAL\ compilers. 1538 1539@<Basic print...@>= 1540procedure print_int(@!n:integer); {prints an integer in decimal form} 1541var k:0..23; {index to current digit; we assume that $|n|<10^{23}$} 1542@!m:integer; {used to negate |n| in possibly dangerous cases} 1543begin k:=0; 1544if n<0 then 1545 begin print_char("-"); 1546 if n>-100000000 then negate(n) 1547 else begin m:=-1-n; n:=m div 10; m:=(m mod 10)+1; k:=1; 1548 if m<10 then dig[0]:=m 1549 else begin dig[0]:=0; incr(n); 1550 end; 1551 end; 1552 end; 1553repeat dig[k]:=n mod 10; n:=n div 10; incr(k); 1554until n=0; 1555print_the_digs(k); 1556end; 1557 1558@ \MF\ also makes use of a trivial procedure to print two digits. The 1559following subroutine is usually called with a parameter in the range |0<=n<=99|. 1560 1561@p procedure print_dd(@!n:integer); {prints two least significant digits} 1562begin n:=abs(n) mod 100; print_char("0"+(n div 10)); 1563print_char("0"+(n mod 10)); 1564end; 1565 1566@ Here is a procedure that asks the user to type a line of input, 1567assuming that the |selector| setting is either |term_only| or |term_and_log|. 1568The input is placed into locations |first| through |last-1| of the 1569|buffer| array, and echoed on the transcript file if appropriate. 1570 1571This procedure is never called when |interaction<scroll_mode|. 1572 1573@d prompt_input(#)==begin wake_up_terminal; print(#); term_input; 1574 end {prints a string and gets a line of input} 1575 1576@p procedure term_input; {gets a line from the terminal} 1577var @!k:0..buf_size; {index into |buffer|} 1578begin update_terminal; {now the user sees the prompt for sure} 1579if not input_ln(term_in,true) then fatal_error("End of file on the terminal!"); 1580@.End of file on the terminal@> 1581term_offset:=0; {the user's line ended with \<\rm return>} 1582decr(selector); {prepare to echo the input} 1583if last<>first then for k:=first to last-1 do print(buffer[k]); 1584print_ln; buffer[last]:="%"; incr(selector); {restore previous status} 1585end; 1586 1587@* \[6] Reporting errors. 1588When something anomalous is detected, \MF\ typically does something like this: 1589$$\vbox{\halign{#\hfil\cr 1590|print_err("Something anomalous has been detected");|\cr 1591|help3("This is the first line of my offer to help.")|\cr 1592|("This is the second line. I'm trying to")|\cr 1593|("explain the best way for you to proceed.");|\cr 1594|error;|\cr}}$$ 1595A two-line help message would be given using |help2|, etc.; these informal 1596helps should use simple vocabulary that complements the words used in the 1597official error message that was printed. (Outside the U.S.A., the help 1598messages should preferably be translated into the local vernacular. Each 1599line of help is at most 60 characters long, in the present implementation, 1600so that |max_print_line| will not be exceeded.) 1601 1602The |print_err| procedure supplies a `\.!' before the official message, 1603and makes sure that the terminal is awake if a stop is going to occur. 1604The |error| procedure supplies a `\..' after the official message, then it 1605shows the location of the error; and if |interaction=error_stop_mode|, 1606it also enters into a dialog with the user, during which time the help 1607message may be printed. 1608@^system dependencies@> 1609 1610@ The global variable |interaction| has four settings, representing increasing 1611amounts of user interaction: 1612 1613@d batch_mode=0 {omits all stops and omits terminal output} 1614@d nonstop_mode=1 {omits all stops} 1615@d scroll_mode=2 {omits error stops} 1616@d error_stop_mode=3 {stops at every opportunity to interact} 1617@d print_err(#)==begin if interaction=error_stop_mode then wake_up_terminal; 1618 print_nl("! "); print(#); 1619@.!\relax@> 1620 end 1621 1622@<Glob...@>= 1623@!interaction:batch_mode..error_stop_mode; {current level of interaction} 1624 1625@ @<Set init...@>=interaction:=error_stop_mode; 1626 1627@ \MF\ is careful not to call |error| when the print |selector| setting 1628might be unusual. The only possible values of |selector| at the time of 1629error messages are 1630 1631\yskip\hang|no_print| (when |interaction=batch_mode| 1632 and |log_file| not yet open); 1633 1634\hang|term_only| (when |interaction>batch_mode| and |log_file| not yet open); 1635 1636\hang|log_only| (when |interaction=batch_mode| and |log_file| is open); 1637 1638\hang|term_and_log| (when |interaction>batch_mode| and |log_file| is open). 1639 1640@<Initialize the print |selector| based on |interaction|@>= 1641if interaction=batch_mode then selector:=no_print@+else selector:=term_only 1642 1643@ A global variable |deletions_allowed| is set |false| if the |get_next| 1644routine is active when |error| is called; this ensures that |get_next| 1645will never be called recursively. 1646@^recursion@> 1647 1648The global variable |history| records the worst level of error that 1649has been detected. It has four possible values: |spotless|, |warning_issued|, 1650|error_message_issued|, and |fatal_error_stop|. 1651 1652Another global variable, |error_count|, is increased by one when an 1653|error| occurs without an interactive dialog, and it is reset to zero at 1654the end of every statement. If |error_count| reaches 100, \MF\ decides 1655that there is no point in continuing further. 1656 1657@d spotless=0 {|history| value when nothing has been amiss yet} 1658@d warning_issued=1 {|history| value when |begin_diagnostic| has been called} 1659@d error_message_issued=2 {|history| value when |error| has been called} 1660@d fatal_error_stop=3 {|history| value when termination was premature} 1661 1662@<Glob...@>= 1663@!deletions_allowed:boolean; {is it safe for |error| to call |get_next|?} 1664@!history:spotless..fatal_error_stop; {has the source input been clean so far?} 1665@!error_count:-1..100; {the number of scrolled errors since the 1666 last statement ended} 1667 1668@ The value of |history| is initially |fatal_error_stop|, but it will 1669be changed to |spotless| if \MF\ survives the initialization process. 1670 1671@<Set init...@>= 1672deletions_allowed:=true; error_count:=0; {|history| is initialized elsewhere} 1673 1674@ Since errors can be detected almost anywhere in \MF, we want to declare the 1675error procedures near the beginning of the program. But the error procedures 1676in turn use some other procedures, which need to be declared |forward| 1677before we get to |error| itself. 1678 1679It is possible for |error| to be called recursively if some error arises 1680when |get_next| is being used to delete a token, and/or if some fatal error 1681occurs while \MF\ is trying to fix a non-fatal one. But such recursion 1682@^recursion@> 1683is never more than two levels deep. 1684 1685@<Error handling...@>= 1686procedure@?normalize_selector; forward;@t\2@>@/ 1687procedure@?get_next; forward;@t\2@>@/ 1688procedure@?term_input; forward;@t\2@>@/ 1689procedure@?show_context; forward;@t\2@>@/ 1690procedure@?begin_file_reading; forward;@t\2@>@/ 1691procedure@?open_log_file; forward;@t\2@>@/ 1692procedure@?close_files_and_terminate; forward;@t\2@>@/ 1693procedure@?clear_for_error_prompt; forward;@t\2@>@/ 1694@t\4\hskip-\fontdimen2\font@>@;@+@!debug@+procedure@?debug_help; 1695 forward;@;@+gubed@;@/ 1696@t\4@>@<Declare the procedure called |flush_string|@> 1697 1698@ Individual lines of help are recorded in the array |help_line|, which 1699contains entries in positions |0..(help_ptr-1)|. They should be printed 1700in reverse order, i.e., with |help_line[0]| appearing last. 1701 1702@d hlp1(#)==help_line[0]:=#;@+end 1703@d hlp2(#)==help_line[1]:=#; hlp1 1704@d hlp3(#)==help_line[2]:=#; hlp2 1705@d hlp4(#)==help_line[3]:=#; hlp3 1706@d hlp5(#)==help_line[4]:=#; hlp4 1707@d hlp6(#)==help_line[5]:=#; hlp5 1708@d help0==help_ptr:=0 {sometimes there might be no help} 1709@d help1==@+begin help_ptr:=1; hlp1 {use this with one help line} 1710@d help2==@+begin help_ptr:=2; hlp2 {use this with two help lines} 1711@d help3==@+begin help_ptr:=3; hlp3 {use this with three help lines} 1712@d help4==@+begin help_ptr:=4; hlp4 {use this with four help lines} 1713@d help5==@+begin help_ptr:=5; hlp5 {use this with five help lines} 1714@d help6==@+begin help_ptr:=6; hlp6 {use this with six help lines} 1715 1716@<Glob...@>= 1717@!help_line:array[0..5] of str_number; {helps for the next |error|} 1718@!help_ptr:0..6; {the number of help lines present} 1719@!use_err_help:boolean; {should the |err_help| string be shown?} 1720@!err_help:str_number; {a string set up by \&{errhelp}} 1721 1722@ @<Set init...@>= 1723help_ptr:=0; use_err_help:=false; err_help:=0; 1724 1725@ The |jump_out| procedure just cuts across all active procedure levels and 1726goes to |end_of_MF|. This is the only nontrivial |@!goto| statement in the 1727whole program. It is used when there is no recovery from a particular error. 1728 1729Some \PASCAL\ compilers do not implement non-local |goto| statements. 1730@^system dependencies@> 1731In such cases the body of |jump_out| should simply be 1732`|close_files_and_terminate|;\thinspace' followed by a call on some system 1733procedure that quietly terminates the program. 1734 1735@<Error hand...@>= 1736procedure jump_out; 1737begin goto end_of_MF; 1738end; 1739 1740@ Here now is the general |error| routine. 1741 1742@<Error hand...@>= 1743procedure error; {completes the job of error reporting} 1744label continue,exit; 1745var @!c:ASCII_code; {what the user types} 1746@!s1,@!s2,@!s3:integer; {used to save global variables when deleting tokens} 1747@!j:pool_pointer; {character position being printed} 1748begin if history<error_message_issued then history:=error_message_issued; 1749print_char("."); show_context; 1750if interaction=error_stop_mode then @<Get user's advice and |return|@>; 1751incr(error_count); 1752if error_count=100 then 1753 begin print_nl("(That makes 100 errors; please try again.)"); 1754@.That makes 100 errors...@> 1755 history:=fatal_error_stop; jump_out; 1756 end; 1757@<Put help message on the transcript file@>; 1758exit:end; 1759 1760@ @<Get user's advice...@>= 1761loop@+begin continue: clear_for_error_prompt; prompt_input("? "); 1762@.?\relax@> 1763 if last=first then return; 1764 c:=buffer[first]; 1765 if c>="a" then c:=c+"A"-"a"; {convert to uppercase} 1766 @<Interpret code |c| and |return| if done@>; 1767 end 1768 1769@ It is desirable to provide an `\.E' option here that gives the user 1770an easy way to return from \MF\ to the system editor, with the offending 1771line ready to be edited. But such an extension requires some system 1772wizardry, so the present implementation simply types out the name of the 1773file that should be 1774edited and the relevant line number. 1775@^system dependencies@> 1776 1777There is a secret `\.D' option available when the debugging routines haven't 1778been commented~out. 1779@^debugging@> 1780 1781@<Interpret code |c| and |return| if done@>= 1782case c of 1783"0","1","2","3","4","5","6","7","8","9": if deletions_allowed then 1784 @<Delete |c-"0"| tokens and |goto continue|@>; 1785@t\4\4@>@;@+@!debug "D":begin debug_help;goto continue;@+end;@+gubed@/ 1786"E": if file_ptr>0 then 1787 begin print_nl("You want to edit file "); 1788@.You want to edit file x@> 1789 slow_print(input_stack[file_ptr].name_field); 1790 print(" at line "); print_int(line);@/ 1791 interaction:=scroll_mode; jump_out; 1792 end; 1793"H": @<Print the help information and |goto continue|@>; 1794"I":@<Introduce new material from the terminal and |return|@>; 1795"Q","R","S":@<Change the interaction level and |return|@>; 1796"X":begin interaction:=scroll_mode; jump_out; 1797 end; 1798othercases do_nothing 1799endcases;@/ 1800@<Print the menu of available options@> 1801 1802@ @<Print the menu...@>= 1803begin print("Type <return> to proceed, S to scroll future error messages,");@/ 1804@.Type <return> to proceed...@> 1805print_nl("R to run without stopping, Q to run quietly,");@/ 1806print_nl("I to insert something, "); 1807if file_ptr>0 then print("E to edit your file,"); 1808if deletions_allowed then 1809 print_nl("1 or ... or 9 to ignore the next 1 to 9 tokens of input,"); 1810print_nl("H for help, X to quit."); 1811end 1812 1813@ Here the author of \MF\ apologizes for making use of the numerical 1814relation between |"Q"|, |"R"|, |"S"|, and the desired interaction settings 1815|batch_mode|, |nonstop_mode|, |scroll_mode|. 1816@^Knuth, Donald Ervin@> 1817 1818@<Change the interaction...@>= 1819begin error_count:=0; interaction:=batch_mode+c-"Q"; 1820print("OK, entering "); 1821case c of 1822"Q":begin print("batchmode"); decr(selector); 1823 end; 1824"R":print("nonstopmode"); 1825"S":print("scrollmode"); 1826end; {there are no other cases} 1827print("..."); print_ln; update_terminal; return; 1828end 1829 1830@ When the following code is executed, |buffer[(first+1)..(last-1)]| may 1831contain the material inserted by the user; otherwise another prompt will 1832be given. In order to understand this part of the program fully, you need 1833to be familiar with \MF's input stacks. 1834 1835@<Introduce new material...@>= 1836begin begin_file_reading; {enter a new syntactic level for terminal input} 1837if last>first+1 then 1838 begin loc:=first+1; buffer[first]:=" "; 1839 end 1840else begin prompt_input("insert>"); loc:=first; 1841@.insert>@> 1842 end; 1843first:=last+1; cur_input.limit_field:=last; return; 1844end 1845 1846@ We allow deletion of up to 99 tokens at a time. 1847 1848@<Delete |c-"0"| tokens...@>= 1849begin s1:=cur_cmd; s2:=cur_mod; s3:=cur_sym; OK_to_interrupt:=false; 1850if (last>first+1) and (buffer[first+1]>="0")and(buffer[first+1]<="9") then 1851 c:=c*10+buffer[first+1]-"0"*11 1852else c:=c-"0"; 1853while c>0 do 1854 begin get_next; {one-level recursive call of |error| is possible} 1855 @<Decrease the string reference count, if the current token is a string@>; 1856 decr(c); 1857 end; 1858cur_cmd:=s1; cur_mod:=s2; cur_sym:=s3; OK_to_interrupt:=true; 1859help2("I have just deleted some text, as you asked.")@/ 1860("You can now delete more, or insert, or whatever."); 1861show_context; goto continue; 1862end 1863 1864@ @<Print the help info...@>= 1865begin if use_err_help then 1866 begin @<Print the string |err_help|, possibly on several lines@>; 1867 use_err_help:=false; 1868 end 1869else begin if help_ptr=0 then 1870 help2("Sorry, I don't know how to help in this situation.")@/ 1871 @t\kern1em@>("Maybe you should try asking a human?"); 1872 repeat decr(help_ptr); print(help_line[help_ptr]); print_ln; 1873 until help_ptr=0; 1874 end; 1875help4("Sorry, I already gave what help I could...")@/ 1876 ("Maybe you should try asking a human?")@/ 1877 ("An error might have occurred before I noticed any problems.")@/ 1878 ("``If all else fails, read the instructions.''");@/ 1879goto continue; 1880end 1881 1882@ @<Print the string |err_help|, possibly on several lines@>= 1883j:=str_start[err_help]; 1884while j<str_start[err_help+1] do 1885 begin if str_pool[j]<>si("%") then print(so(str_pool[j])) 1886 else if j+1=str_start[err_help+1] then print_ln 1887 else if str_pool[j+1]<>si("%") then print_ln 1888 else begin incr(j); print_char("%"); 1889 end; 1890 incr(j); 1891 end 1892 1893@ @<Put help message on the transcript file@>= 1894if interaction>batch_mode then decr(selector); {avoid terminal output} 1895if use_err_help then 1896 begin print_nl(""); 1897 @<Print the string |err_help|, possibly on several lines@>; 1898 end 1899else while help_ptr>0 do 1900 begin decr(help_ptr); print_nl(help_line[help_ptr]); 1901 end; 1902print_ln; 1903if interaction>batch_mode then incr(selector); {re-enable terminal output} 1904print_ln 1905 1906@ In anomalous cases, the print selector might be in an unknown state; 1907the following subroutine is called to fix things just enough to keep 1908running a bit longer. 1909 1910@p procedure normalize_selector; 1911begin if log_opened then selector:=term_and_log 1912else selector:=term_only; 1913if job_name=0 then open_log_file; 1914if interaction=batch_mode then decr(selector); 1915end; 1916 1917@ The following procedure prints \MF's last words before dying. 1918 1919@d succumb==begin if interaction=error_stop_mode then 1920 interaction:=scroll_mode; {no more interaction} 1921 if log_opened then error; 1922 @!debug if interaction>batch_mode then debug_help;@;@+gubed@;@/ 1923 history:=fatal_error_stop; jump_out; {irrecoverable error} 1924 end 1925 1926@<Error hand...@>= 1927procedure fatal_error(@!s:str_number); {prints |s|, and that's it} 1928begin normalize_selector;@/ 1929print_err("Emergency stop"); help1(s); succumb; 1930@.Emergency stop@> 1931end; 1932 1933@ Here is the most dreaded error message. 1934 1935@<Error hand...@>= 1936procedure overflow(@!s:str_number;@!n:integer); {stop due to finiteness} 1937begin normalize_selector; 1938print_err("METAFONT capacity exceeded, sorry ["); 1939@.METAFONT capacity exceeded ...@> 1940print(s); print_char("="); print_int(n); print_char("]"); 1941help2("If you really absolutely need more capacity,")@/ 1942 ("you can ask a wizard to enlarge me."); 1943succumb; 1944end; 1945 1946@ The program might sometime run completely amok, at which point there is 1947no choice but to stop. If no previous error has been detected, that's bad 1948news; a message is printed that is really intended for the \MF\ 1949maintenance person instead of the user (unless the user has been 1950particularly diabolical). The index entries for `this can't happen' may 1951help to pinpoint the problem. 1952@^dry rot@> 1953 1954@<Error hand...@>= 1955procedure confusion(@!s:str_number); 1956 {consistency check violated; |s| tells where} 1957begin normalize_selector; 1958if history<error_message_issued then 1959 begin print_err("This can't happen ("); print(s); print_char(")"); 1960@.This can't happen@> 1961 help1("I'm broken. Please show this to someone who can fix can fix"); 1962 end 1963else begin print_err("I can't go on meeting you like this"); 1964@.I can't go on...@> 1965 help2("One of your faux pas seems to have wounded me deeply...")@/ 1966 ("in fact, I'm barely conscious. Please fix it and try again."); 1967 end; 1968succumb; 1969end; 1970 1971@ Users occasionally want to interrupt \MF\ while it's running. 1972If the \PASCAL\ runtime system allows this, one can implement 1973a routine that sets the global variable |interrupt| to some nonzero value 1974when such an interrupt is signalled. Otherwise there is probably at least 1975a way to make |interrupt| nonzero using the \PASCAL\ debugger. 1976@^system dependencies@> 1977@^debugging@> 1978 1979@d check_interrupt==begin if interrupt<>0 then pause_for_instructions; 1980 end 1981 1982@<Global...@>= 1983@!interrupt:integer; {should \MF\ pause for instructions?} 1984@!OK_to_interrupt:boolean; {should interrupts be observed?} 1985 1986@ @<Set init...@>= 1987interrupt:=0; OK_to_interrupt:=true; 1988 1989@ When an interrupt has been detected, the program goes into its 1990highest interaction level and lets the user have the full flexibility of 1991the |error| routine. \MF\ checks for interrupts only at times when it is 1992safe to do this. 1993 1994@p procedure pause_for_instructions; 1995begin if OK_to_interrupt then 1996 begin interaction:=error_stop_mode; 1997 if (selector=log_only)or(selector=no_print) then 1998 incr(selector); 1999 print_err("Interruption"); 2000@.Interruption@> 2001 help3("You rang?")@/ 2002 ("Try to insert some instructions for me (e.g.,`I show x'),")@/ 2003 ("unless you just want to quit by typing `X'."); 2004 deletions_allowed:=false; error; deletions_allowed:=true; 2005 interrupt:=0; 2006 end; 2007end; 2008 2009@ Many of \MF's error messages state that a missing token has been 2010inserted behind the scenes. We can save string space and program space 2011by putting this common code into a subroutine. 2012 2013@p procedure missing_err(@!s:str_number); 2014begin print_err("Missing `"); print(s); print("' has been inserted"); 2015@.Missing...inserted@> 2016end; 2017 2018@* \[7] Arithmetic with scaled numbers. 2019The principal computations performed by \MF\ are done entirely in terms of 2020integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this 2021program can be carried out in exactly the same way on a wide variety of 2022computers, including some small ones. 2023@^small computers@> 2024 2025But \PASCAL\ does not define the @!|div| 2026operation in the case of negative dividends; for example, the result of 2027|(-2*n-1) div 2| is |-(n+1)| on some computers and |-n| on others. 2028There are two principal types of arithmetic: ``translation-preserving,'' 2029in which the identity |(a+q*b)div b=(a div b)+q| is valid; and 2030``negation-preserving,'' in which |(-a)div b=-(a div b)|. This leads to 2031two \MF s, which can produce different results, although the differences 2032should be negligible when the language is being used properly. 2033The \TeX\ processor has been defined carefully so that both varieties 2034of arithmetic will produce identical output, but it would be too 2035inefficient to constrain \MF\ in a similar way. 2036 2037@d el_gordo == @'17777777777 {$2^{31}-1$, the largest value that \MF\ likes} 2038 2039@ One of \MF's most common operations is the calculation of 2040$\lfloor{a+b\over2}\rfloor$, 2041the midpoint of two given integers |a| and~|b|. The only decent way to do 2042this in \PASCAL\ is to write `|(a+b) div 2|'; but on most machines it is 2043far more efficient to calculate `|(a+b)| right shifted one bit'. 2044 2045Therefore the midpoint operation will always be denoted by `|half(a+b)|' 2046in this program. If \MF\ is being implemented with languages that permit 2047binary shifting, the |half| macro should be changed to make this operation 2048as efficient as possible. 2049 2050@d half(#)==(#) div 2 2051 2052@ A single computation might use several subroutine calls, and it is 2053desirable to avoid producing multiple error messages in case of arithmetic 2054overflow. So the routines below set the global variable |arith_error| to |true| 2055instead of reporting errors directly to the user. 2056@^overflow in arithmetic@> 2057 2058@<Glob...@>= 2059@!arith_error:boolean; {has arithmetic overflow occurred recently?} 2060 2061@ @<Set init...@>= 2062arith_error:=false; 2063 2064@ At crucial points the program will say |check_arith|, to test if 2065an arithmetic error has been detected. 2066 2067@d check_arith==begin if arith_error then clear_arith;@+end 2068 2069@p procedure clear_arith; 2070begin print_err("Arithmetic overflow"); 2071@.Arithmetic overflow@> 2072help4("Uh, oh. A little while ago one of the quantities that I was")@/ 2073 ("computing got too large, so I'm afraid your answers will be")@/ 2074 ("somewhat askew. You'll probably have to adopt different")@/ 2075 ("tactics next time. But I shall try to carry on anyway."); 2076error; arith_error:=false; 2077end; 2078 2079@ Addition is not always checked to make sure that it doesn't overflow, 2080but in places where overflow isn't too unlikely the |slow_add| routine 2081is used. 2082 2083@p function slow_add(@!x,@!y:integer):integer; 2084begin if x>=0 then 2085 if y<=el_gordo-x then slow_add:=x+y 2086 else begin arith_error:=true; slow_add:=el_gordo; 2087 end 2088else if -y<=el_gordo+x then slow_add:=x+y 2089 else begin arith_error:=true; slow_add:=-el_gordo; 2090 end; 2091end; 2092 2093@ Fixed-point arithmetic is done on {\sl scaled integers\/} that are multiples 2094of $2^{-16}$. In other words, a binary point is assumed to be sixteen bit 2095positions from the right end of a binary computer word. 2096 2097@d quarter_unit == @'40000 {$2^{14}$, represents 0.250000} 2098@d half_unit == @'100000 {$2^{15}$, represents 0.50000} 2099@d three_quarter_unit == @'140000 {$3\cdot2^{14}$, represents 0.75000} 2100@d unity == @'200000 {$2^{16}$, represents 1.00000} 2101@d two == @'400000 {$2^{17}$, represents 2.00000} 2102@d three == @'600000 {$2^{17}+2^{16}$, represents 3.00000} 2103 2104@<Types...@>= 2105@!scaled = integer; {this type is used for scaled integers} 2106@!small_number=0..63; {this type is self-explanatory} 2107 2108@ The following function is used to create a scaled integer from a given decimal 2109fraction $(.d_0d_1\ldots d_{k-1})$, where |0<=k<=17|. The digit $d_i$ is 2110given in |dig[i]|, and the calculation produces a correctly rounded result. 2111 2112@p function round_decimals(@!k:small_number) : scaled; 2113 {converts a decimal fraction} 2114var @!a:integer; {the accumulator} 2115begin a:=0; 2116while k>0 do 2117 begin decr(k); a:=(a+dig[k]*two) div 10; 2118 end; 2119round_decimals:=half(a+1); 2120end; 2121 2122@ Conversely, here is a procedure analogous to |print_int|. If the output 2123of this procedure is subsequently read by \MF\ and converted by the 2124|round_decimals| routine above, it turns out that the original value will 2125be reproduced exactly. A decimal point is printed only if the value is 2126not an integer. If there is more than one way to print the result with 2127the optimum number of digits following the decimal point, the closest 2128possible value is given. 2129 2130The invariant relation in the \&{repeat} loop is that a sequence of 2131decimal digits yet to be printed will yield the original number if and only if 2132they form a fraction~$f$ in the range $s-\delta\L10\cdot2^{16}f<s$. 2133We can stop if and only if $f=0$ satisfies this condition; the loop will 2134terminate before $s$ can possibly become zero. 2135 2136@<Basic printing...@>= 2137procedure print_scaled(@!s:scaled); {prints scaled real, rounded to five 2138 digits} 2139var @!delta:scaled; {amount of allowable inaccuracy} 2140begin if s<0 then 2141 begin print_char("-"); negate(s); {print the sign, if negative} 2142 end; 2143print_int(s div unity); {print the integer part} 2144s:=10*(s mod unity)+5; 2145if s<>5 then 2146 begin delta:=10; print_char("."); 2147 repeat if delta>unity then 2148 s:=s+@'100000-(delta div 2); {round the final digit} 2149 print_char("0"+(s div unity)); s:=10*(s mod unity); delta:=delta*10; 2150 until s<=delta; 2151 end; 2152end; 2153 2154@ We often want to print two scaled quantities in parentheses, 2155separated by a comma. 2156 2157@<Basic printing...@>= 2158procedure print_two(@!x,@!y:scaled); {prints `|(x,y)|'} 2159begin print_char("("); print_scaled(x); print_char(","); print_scaled(y); 2160print_char(")"); 2161end; 2162 2163@ The |scaled| quantities in \MF\ programs are generally supposed to be 2164less than $2^{12}$ in absolute value, so \MF\ does much of its internal 2165arithmetic with 28~significant bits of precision. A |fraction| denotes 2166a scaled integer whose binary point is assumed to be 28 bit positions 2167from the right. 2168 2169@d fraction_half==@'1000000000 {$2^{27}$, represents 0.50000000} 2170@d fraction_one==@'2000000000 {$2^{28}$, represents 1.00000000} 2171@d fraction_two==@'4000000000 {$2^{29}$, represents 2.00000000} 2172@d fraction_three==@'6000000000 {$3\cdot2^{28}$, represents 3.00000000} 2173@d fraction_four==@'10000000000 {$2^{30}$, represents 4.00000000} 2174 2175@<Types...@>= 2176@!fraction=integer; {this type is used for scaled fractions} 2177 2178@ In fact, the two sorts of scaling discussed above aren't quite 2179sufficient; \MF\ has yet another, used internally to keep track of angles 2180in units of $2^{-20}$ degrees. 2181 2182@d forty_five_deg==@'264000000 {$45\cdot2^{20}$, represents $45^\circ$} 2183@d ninety_deg==@'550000000 {$90\cdot2^{20}$, represents $90^\circ$} 2184@d one_eighty_deg==@'1320000000 {$180\cdot2^{20}$, represents $180^\circ$} 2185@d three_sixty_deg==@'2640000000 {$360\cdot2^{20}$, represents $360^\circ$} 2186 2187@<Types...@>= 2188@!angle=integer; {this type is used for scaled angles} 2189 2190@ The |make_fraction| routine produces the |fraction| equivalent of 2191|p/q|, given integers |p| and~|q|; it computes the integer 2192$f=\lfloor2^{28}p/q+{1\over2}\rfloor$, when $p$ and $q$ are 2193positive. If |p| and |q| are both of the same scaled type |t|, 2194the ``type relation'' |make_fraction(t,t)=fraction| is valid; 2195and it's also possible to use the subroutine ``backwards,'' using 2196the relation |make_fraction(t,fraction)=t| between scaled types. 2197 2198If the result would have magnitude $2^{31}$ or more, |make_fraction| 2199sets |arith_error:=true|. Most of \MF's internal computations have 2200been designed to avoid this sort of error. 2201 2202Notice that if 64-bit integer arithmetic were available, 2203we could simply compute |(@t$(2^{29}$@>*p+q)div (2*q)|. 2204But when we are restricted to \PASCAL's 32-bit arithmetic we 2205must either resort to multiple-precision maneuvering 2206or use a simple but slow iteration. The multiple-precision technique 2207would be about three times faster than the code adopted here, but it 2208would be comparatively long and tricky, involving about sixteen 2209additional multiplications and divisions. 2210 2211This operation is part of \MF's ``inner loop''; indeed, it will 2212consume nearly 10\pct! of the running time (exclusive of input and output) 2213if the code below is left unchanged. A machine-dependent recoding 2214will therefore make \MF\ run faster. The present implementation 2215is highly portable, but slow; it avoids multiplication and division 2216except in the initial stage. System wizards should be careful to 2217replace it with a routine that is guaranteed to produce identical 2218results in all cases. 2219@^system dependencies@> 2220 2221As noted below, a few more routines should also be replaced by machine-dependent 2222code, for efficiency. But when a procedure is not part of the ``inner loop,'' 2223such changes aren't advisable; simplicity and robustness are 2224preferable to trickery, unless the cost is too high. 2225@^inner loop@> 2226 2227@p function make_fraction(@!p,@!q:integer):fraction; 2228var @!f:integer; {the fraction bits, with a leading 1 bit} 2229@!n:integer; {the integer part of $\vert p/q\vert$} 2230@!negative:boolean; {should the result be negated?} 2231@!be_careful:integer; {disables certain compiler optimizations} 2232begin if p>=0 then negative:=false 2233else begin negate(p); negative:=true; 2234 end; 2235if q<=0 then 2236 begin debug if q=0 then confusion("/");@;@+gubed@;@/ 2237@:this can't happen /}{\quad \./@> 2238 negate(q); negative:=not negative; 2239 end; 2240n:=p div q; p:=p mod q; 2241if n>=8 then 2242 begin arith_error:=true; 2243 if negative then make_fraction:=-el_gordo@+else make_fraction:=el_gordo; 2244 end 2245else begin n:=(n-1)*fraction_one; 2246 @<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>; 2247 if negative then make_fraction:=-(f+n)@+else make_fraction:=f+n; 2248 end; 2249end; 2250 2251@ The |repeat| loop here preserves the following invariant relations 2252between |f|, |p|, and~|q|: 2253(i)~|0<=p<q|; (ii)~$fq+p=2^k(q+p_0)$, where $k$ is an integer and 2254$p_0$ is the original value of~$p$. 2255 2256Notice that the computation specifies 2257|(p-q)+p| instead of |(p+p)-q|, because the latter could overflow. 2258Let us hope that optimizing compilers do not miss this point; a 2259special variable |be_careful| is used to emphasize the necessary 2260order of computation. Optimizing compilers should keep |be_careful| 2261in a register, not store it in memory. 2262@^inner loop@> 2263 2264@<Compute $f=\lfloor 2^{28}(1+p/q)+{1\over2}\rfloor$@>= 2265f:=1; 2266repeat be_careful:=p-q; p:=be_careful+p; 2267if p>=0 then f:=f+f+1 2268else begin double(f); p:=p+q; 2269 end; 2270until f>=fraction_one; 2271be_careful:=p-q; 2272if be_careful+p>=0 then incr(f) 2273 2274@ The dual of |make_fraction| is |take_fraction|, which multiplies a 2275given integer~|q| by a fraction~|f|. When the operands are positive, it 2276computes $p=\lfloor qf/2^{28}+{1\over2}\rfloor$, a symmetric function 2277of |q| and~|f|. 2278 2279This routine is even more ``inner loopy'' than |make_fraction|; 2280the present implementation consumes almost 20\pct! of \MF's computation 2281time during typical jobs, so a machine-language or 64-bit 2282substitute is advisable. 2283@^inner loop@> @^system dependencies@> 2284 2285@p function take_fraction(@!q:integer;@!f:fraction):integer; 2286var @!p:integer; {the fraction so far} 2287@!negative:boolean; {should the result be negated?} 2288@!n:integer; {additional multiple of $q$} 2289@!be_careful:integer; {disables certain compiler optimizations} 2290begin @<Reduce to the case that |f>=0| and |q>=0|@>; 2291if f<fraction_one then n:=0 2292else begin n:=f div fraction_one; f:=f mod fraction_one; 2293 if q<=el_gordo div n then n:=n*q 2294 else begin arith_error:=true; n:=el_gordo; 2295 end; 2296 end; 2297f:=f+fraction_one; 2298@<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>; 2299be_careful:=n-el_gordo; 2300if be_careful+p>0 then 2301 begin arith_error:=true; n:=el_gordo-p; 2302 end; 2303if negative then take_fraction:=-(n+p) 2304else take_fraction:=n+p; 2305end; 2306 2307@ @<Reduce to the case that |f>=0| and |q>=0|@>= 2308if f>=0 then negative:=false 2309else begin negate(f); negative:=true; 2310 end; 2311if q<0 then 2312 begin negate(q); negative:=not negative; 2313 end; 2314 2315@ The invariant relations in this case are (i)~$\lfloor(qf+p)/2^k\rfloor 2316=\lfloor qf_0/2^{28}+{1\over2}\rfloor$, where $k$ is an integer and 2317$f_0$ is the original value of~$f$; (ii)~$2^k\L f<2^{k+1}$. 2318@^inner loop@> 2319 2320@<Compute $p=\lfloor qf/2^{28}+{1\over2}\rfloor-q$@>= 2321p:=fraction_half; {that's $2^{27}$; the invariants hold now with $k=28$} 2322if q<fraction_four then 2323 repeat if odd(f) then p:=half(p+q)@+else p:=half(p); 2324 f:=half(f); 2325 until f=1 2326else repeat if odd(f) then p:=p+half(q-p)@+else p:=half(p); 2327 f:=half(f); 2328 until f=1 2329 2330 2331@ When we want to multiply something by a |scaled| quantity, we use a scheme 2332analogous to |take_fraction| but with a different scaling. 2333Given positive operands, |take_scaled| 2334computes the quantity $p=\lfloor qf/2^{16}+{1\over2}\rfloor$. 2335 2336Once again it is a good idea to use 64-bit arithmetic if 2337possible; otherwise |take_scaled| will use more than 2\pct! of the running time 2338when the Computer Modern fonts are being generated. 2339@^inner loop@> 2340 2341@p function take_scaled(@!q:integer;@!f:scaled):integer; 2342var @!p:integer; {the fraction so far} 2343@!negative:boolean; {should the result be negated?} 2344@!n:integer; {additional multiple of $q$} 2345@!be_careful:integer; {disables certain compiler optimizations} 2346begin @<Reduce to the case that |f>=0| and |q>=0|@>; 2347if f<unity then n:=0 2348else begin n:=f div unity; f:=f mod unity; 2349 if q<=el_gordo div n then n:=n*q 2350 else begin arith_error:=true; n:=el_gordo; 2351 end; 2352 end; 2353f:=f+unity; 2354@<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>; 2355be_careful:=n-el_gordo; 2356if be_careful+p>0 then 2357 begin arith_error:=true; n:=el_gordo-p; 2358 end; 2359if negative then take_scaled:=-(n+p) 2360else take_scaled:=n+p; 2361end; 2362 2363@ @<Compute $p=\lfloor qf/2^{16}+{1\over2}\rfloor-q$@>= 2364p:=half_unit; {that's $2^{15}$; the invariants hold now with $k=16$} 2365@^inner loop@> 2366if q<fraction_four then 2367 repeat if odd(f) then p:=half(p+q)@+else p:=half(p); 2368 f:=half(f); 2369 until f=1 2370else repeat if odd(f) then p:=p+half(q-p)@+else p:=half(p); 2371 f:=half(f); 2372 until f=1 2373 2374@ For completeness, there's also |make_scaled|, which computes a 2375quotient as a |scaled| number instead of as a |fraction|. 2376In other words, the result is $\lfloor2^{16}p/q+{1\over2}\rfloor$, if the 2377operands are positive. \ (This procedure is not used especially often, 2378so it is not part of \MF's inner loop.) 2379 2380@p function make_scaled(@!p,@!q:integer):scaled; 2381var @!f:integer; {the fraction bits, with a leading 1 bit} 2382@!n:integer; {the integer part of $\vert p/q\vert$} 2383@!negative:boolean; {should the result be negated?} 2384@!be_careful:integer; {disables certain compiler optimizations} 2385begin if p>=0 then negative:=false 2386else begin negate(p); negative:=true; 2387 end; 2388if q<=0 then 2389 begin debug if q=0 then confusion("/");@+gubed@;@/ 2390@:this can't happen /}{\quad \./@> 2391 negate(q); negative:=not negative; 2392 end; 2393n:=p div q; p:=p mod q; 2394if n>=@'100000 then 2395 begin arith_error:=true; 2396 if negative then make_scaled:=-el_gordo@+else make_scaled:=el_gordo; 2397 end 2398else begin n:=(n-1)*unity; 2399 @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>; 2400 if negative then make_scaled:=-(f+n)@+else make_scaled:=f+n; 2401 end; 2402end; 2403 2404@ @<Compute $f=\lfloor 2^{16}(1+p/q)+{1\over2}\rfloor$@>= 2405f:=1; 2406repeat be_careful:=p-q; p:=be_careful+p; 2407if p>=0 then f:=f+f+1 2408else begin double(f); p:=p+q; 2409 end; 2410until f>=unity; 2411be_careful:=p-q; 2412if be_careful+p>=0 then incr(f) 2413 2414@ Here is a typical example of how the routines above can be used. 2415It computes the function 2416$${1\over3\tau}f(\theta,\phi)= 2417{\tau^{-1}\bigl(2+\sqrt2\,(\sin\theta-{1\over16}\sin\phi) 2418 (\sin\phi-{1\over16}\sin\theta)(\cos\theta-\cos\phi)\bigr)\over 24193\,\bigl(1+{1\over2}(\sqrt5-1)\cos\theta+{1\over2}(3-\sqrt5\,)\cos\phi\bigr)},$$ 2420where $\tau$ is a |scaled| ``tension'' parameter. This is \MF's magic 2421fudge factor for placing the first control point of a curve that starts 2422at an angle $\theta$ and ends at an angle $\phi$ from the straight path. 2423(Actually, if the stated quantity exceeds 4, \MF\ reduces it to~4.) 2424 2425The trigonometric quantity to be multiplied by $\sqrt2$ is less than $\sqrt2$. 2426(It's a sum of eight terms whose absolute values can be bounded using 2427relations such as $\sin\theta\cos\theta\L{1\over2}$.) Thus the numerator 2428is positive; and since the tension $\tau$ is constrained to be at least 2429$3\over4$, the numerator is less than $16\over3$. The denominator is 2430nonnegative and at most~6. Hence the fixed-point calculations below 2431are guaranteed to stay within the bounds of a 32-bit computer word. 2432 2433The angles $\theta$ and $\phi$ are given implicitly in terms of |fraction| 2434arguments |st|, |ct|, |sf|, and |cf|, representing $\sin\theta$, $\cos\theta$, 2435$\sin\phi$, and $\cos\phi$, respectively. 2436 2437@p function velocity(@!st,@!ct,@!sf,@!cf:fraction;@!t:scaled):fraction; 2438var @!acc,@!num,@!denom:integer; {registers for intermediate calculations} 2439begin acc:=take_fraction(st-(sf div 16), sf-(st div 16)); 2440acc:=take_fraction(acc,ct-cf); 2441num:=fraction_two+take_fraction(acc,379625062); 2442 {$2^{28}\sqrt2\approx379625062.497$} 2443denom:=fraction_three+take_fraction(ct,497706707)+take_fraction(cf,307599661); 2444 {$3\cdot2^{27}\cdot(\sqrt5-1)\approx497706706.78$ and 2445 $3\cdot2^{27}\cdot(3-\sqrt5\,)\approx307599661.22$} 2446if t<>unity then num:=make_scaled(num,t); 2447 {|make_scaled(fraction,scaled)=fraction|} 2448if num div 4>=denom then velocity:=fraction_four 2449else velocity:=make_fraction(num,denom); 2450end; 2451 2452@ The following somewhat different subroutine tests rigorously if $ab$ is 2453greater than, equal to, or less than~$cd$, 2454given integers $(a,b,c,d)$. In most cases a quick decision is reached. 2455The result is $+1$, 0, or~$-1$ in the three respective cases. 2456 2457@d return_sign(#)==begin ab_vs_cd:=#; return; 2458 end 2459 2460@p function ab_vs_cd(@!a,b,c,d:integer):integer; 2461label exit; 2462var @!q,@!r:integer; {temporary registers} 2463begin @<Reduce to the case that |a,c>=0|, |b,d>0|@>; 2464loop@+ begin q := a div d; r := c div b; 2465 if q<>r then 2466 if q>r then return_sign(1)@+else return_sign(-1); 2467 q := a mod d; r := c mod b; 2468 if r=0 then 2469 if q=0 then return_sign(0)@+else return_sign(1); 2470 if q=0 then return_sign(-1); 2471 a:=b; b:=q; c:=d; d:=r; 2472 end; {now |a>d>0| and |c>b>0|} 2473exit:end; 2474 2475@ @<Reduce to the case that |a...@>= 2476if a<0 then 2477 begin negate(a); negate(b); 2478 end; 2479if c<0 then 2480 begin negate(c); negate(d); 2481 end; 2482if d<=0 then 2483 begin if b>=0 then 2484 if ((a=0)or(b=0))and((c=0)or(d=0)) then return_sign(0) 2485 else return_sign(1); 2486 if d=0 then 2487 if a=0 then return_sign(0)@+else return_sign(-1); 2488 q:=a; a:=c; c:=q; q:=-b; b:=-d; d:=q; 2489 end 2490else if b<=0 then 2491 begin if b<0 then if a>0 then return_sign(-1); 2492 if c=0 then return_sign(0) else return_sign(-1); 2493 end 2494 2495@ We conclude this set of elementary routines with some simple rounding 2496and truncation operations that are coded in a machine-independent fashion. 2497The routines are slightly complicated because we want them to work 2498without overflow whenever $-2^{31}\L x<2^{31}$. 2499 2500@p function floor_scaled(@!x:scaled):scaled; 2501 {$2^{16}\lfloor x/2^{16}\rfloor$} 2502var @!be_careful:integer; {temporary register} 2503begin if x>=0 then floor_scaled:=x-(x mod unity) 2504else begin be_careful:=x+1; 2505 floor_scaled:=x+((-be_careful) mod unity)+1-unity; 2506 end; 2507end; 2508@# 2509function floor_unscaled(@!x:scaled):integer; 2510 {$\lfloor x/2^{16}\rfloor$} 2511var @!be_careful:integer; {temporary register} 2512begin if x>=0 then floor_unscaled:=x div unity 2513else begin be_careful:=x+1; floor_unscaled:=-(1+((-be_careful) div unity)); 2514 end; 2515end; 2516@# 2517function round_unscaled(@!x:scaled):integer; 2518 {$\lfloor x/2^{16}+.5\rfloor$} 2519var @!be_careful:integer; {temporary register} 2520begin if x>=half_unit then round_unscaled:=1+((x-half_unit) div unity) 2521else if x>=-half_unit then round_unscaled:=0 2522else begin be_careful:=x+1; 2523 round_unscaled:=-(1+((-be_careful-half_unit) div unity)); 2524 end; 2525end; 2526@# 2527function round_fraction(@!x:fraction):scaled; 2528 {$\lfloor x/2^{12}+.5\rfloor$} 2529var @!be_careful:integer; {temporary register} 2530begin if x>=2048 then round_fraction:=1+((x-2048) div 4096) 2531else if x>=-2048 then round_fraction:=0 2532else begin be_careful:=x+1; 2533 round_fraction:=-(1+((-be_careful-2048) div 4096)); 2534 end; 2535end; 2536 2537@* \[8] Algebraic and transcendental functions. 2538\MF\ computes all of the necessary special functions from scratch, without 2539relying on |real| arithmetic or system subroutines for sines, cosines, etc. 2540 2541@ To get the square root of a |scaled| number |x|, we want to calculate 2542$s=\lfloor 2^8\!\sqrt x +{1\over2}\rfloor$. If $x>0$, this is the unique 2543integer such that $2^{16}x-s\L s^2<2^{16}x+s$. The following subroutine 2544determines $s$ by an iterative method that maintains the invariant 2545relations $x=2^{46-2k}x_0\bmod 2^{30}$, $0<y=\lfloor 2^{16-2k}x_0\rfloor 2546-s^2+s\L q=2s$, where $x_0$ is the initial value of $x$. The value of~$y$ 2547might, however, be zero at the start of the first iteration. 2548 2549@p function square_rt(@!x:scaled):scaled; 2550var @!k:small_number; {iteration control counter} 2551@!y,@!q:integer; {registers for intermediate calculations} 2552begin if x<=0 then @<Handle square root of zero or negative argument@> 2553else begin k:=23; q:=2; 2554 while x<fraction_two do {i.e., |while x<@t$2^{29}$@>|\unskip} 2555 begin decr(k); x:=x+x+x+x; 2556 end; 2557 if x<fraction_four then y:=0 2558 else begin x:=x-fraction_four; y:=1; 2559 end; 2560 repeat @<Decrease |k| by 1, maintaining the invariant 2561 relations between |x|, |y|, and~|q|@>; 2562 until k=0; 2563 square_rt:=half(q); 2564 end; 2565end; 2566 2567@ @<Handle square root of zero...@>= 2568begin if x<0 then 2569 begin print_err("Square root of "); 2570@.Square root...replaced by 0@> 2571 print_scaled(x); print(" has been replaced by 0"); 2572 help2("Since I don't take square roots of negative numbers,")@/ 2573 ("I'm zeroing this one. Proceed, with fingers crossed."); 2574 error; 2575 end; 2576square_rt:=0; 2577end 2578 2579@ @<Decrease |k| by 1, maintaining...@>= 2580double(x); double(y); 2581if x>=fraction_four then {note that |fraction_four=@t$2^{30}$@>|} 2582 begin x:=x-fraction_four; incr(y); 2583 end; 2584double(x); y:=y+y-q; double(q); 2585if x>=fraction_four then 2586 begin x:=x-fraction_four; incr(y); 2587 end; 2588if y>q then 2589 begin y:=y-q; q:=q+2; 2590 end 2591else if y<=0 then 2592 begin q:=q-2; y:=y+q; 2593 end; 2594decr(k) 2595 2596@ Pythagorean addition $\psqrt{a^2+b^2}$ is implemented by an elegant 2597iterative scheme due to Cleve Moler and Donald Morrison [{\sl IBM Journal 2598@^Moler, Cleve Barry@> 2599@^Morrison, Donald Ross@> 2600of Research and Development\/ \bf27} (1983), 577--581]. It modifies |a| and~|b| 2601in such a way that their Pythagorean sum remains invariant, while the 2602smaller argument decreases. 2603 2604@p function pyth_add(@!a,@!b:integer):integer; 2605label done; 2606var @!r:fraction; {register used to transform |a| and |b|} 2607@!big:boolean; {is the result dangerously near $2^{31}$?} 2608begin a:=abs(a); b:=abs(b); 2609if a<b then 2610 begin r:=b; b:=a; a:=r; 2611 end; {now |0<=b<=a|} 2612if b>0 then 2613 begin if a<fraction_two then big:=false 2614 else begin a:=a div 4; b:=b div 4; big:=true; 2615 end; {we reduced the precision to avoid arithmetic overflow} 2616 @<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>; 2617 if big then 2618 if a<fraction_two then a:=a+a+a+a 2619 else begin arith_error:=true; a:=el_gordo; 2620 end; 2621 end; 2622pyth_add:=a; 2623end; 2624 2625@ The key idea here is to reflect the vector $(a,b)$ about the 2626line through $(a,b/2)$. 2627 2628@<Replace |a| by an approximation to $\psqrt{a^2+b^2}$@>= 2629loop@+ begin r:=make_fraction(b,a); 2630 r:=take_fraction(r,r); {now $r\approx b^2/a^2$} 2631 if r=0 then goto done; 2632 r:=make_fraction(r,fraction_four+r); 2633 a:=a+take_fraction(a+a,r); b:=take_fraction(b,r); 2634 end; 2635done: 2636 2637@ Here is a similar algorithm for $\psqrt{a^2-b^2}$. 2638It converges slowly when $b$ is near $a$, but otherwise it works fine. 2639 2640@p function pyth_sub(@!a,@!b:integer):integer; 2641label done; 2642var @!r:fraction; {register used to transform |a| and |b|} 2643@!big:boolean; {is the input dangerously near $2^{31}$?} 2644begin a:=abs(a); b:=abs(b); 2645if a<=b then @<Handle erroneous |pyth_sub| and set |a:=0|@> 2646else begin if a<fraction_four then big:=false 2647 else begin a:=half(a); b:=half(b); big:=true; 2648 end; 2649 @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>; 2650 if big then a:=a+a; 2651 end; 2652pyth_sub:=a; 2653end; 2654 2655@ @<Replace |a| by an approximation to $\psqrt{a^2-b^2}$@>= 2656loop@+ begin r:=make_fraction(b,a); 2657 r:=take_fraction(r,r); {now $r\approx b^2/a^2$} 2658 if r=0 then goto done; 2659 r:=make_fraction(r,fraction_four-r); 2660 a:=a-take_fraction(a+a,r); b:=take_fraction(b,r); 2661 end; 2662done: 2663 2664@ @<Handle erroneous |pyth_sub| and set |a:=0|@>= 2665begin if a<b then 2666 begin print_err("Pythagorean subtraction "); print_scaled(a); 2667 print("+-+"); print_scaled(b); print(" has been replaced by 0"); 2668@.Pythagorean...@> 2669 help2("Since I don't take square roots of negative numbers,")@/ 2670 ("I'm zeroing this one. Proceed, with fingers crossed."); 2671 error; 2672 end; 2673a:=0; 2674end 2675 2676@ The subroutines for logarithm and exponential involve two tables. 2677The first is simple: |two_to_the[k]| equals $2^k$. The second involves 2678a bit more calculation, which the author claims to have done correctly: 2679|spec_log[k]| is $2^{27}$ times $\ln\bigl(1/(1-2^{-k})\bigr)= 26802^{-k}+{1\over2}2^{-2k}+{1\over3}2^{-3k}+\cdots\,$, rounded to the 2681nearest integer. 2682 2683@<Glob...@>= 2684@!two_to_the:array[0..30] of integer; {powers of two} 2685@!spec_log:array[1..28] of integer; {special logarithms} 2686 2687@ @<Local variables for initialization@>= 2688@!k:integer; {all-purpose loop index} 2689 2690@ @<Set init...@>= 2691two_to_the[0]:=1; 2692for k:=1 to 30 do two_to_the[k]:=2*two_to_the[k-1]; 2693spec_log[1]:=93032640; 2694spec_log[2]:=38612034; 2695spec_log[3]:=17922280; 2696spec_log[4]:=8662214; 2697spec_log[5]:=4261238; 2698spec_log[6]:=2113709; 2699spec_log[7]:=1052693; 2700spec_log[8]:=525315; 2701spec_log[9]:=262400; 2702spec_log[10]:=131136; 2703spec_log[11]:=65552; 2704spec_log[12]:=32772; 2705spec_log[13]:=16385; 2706for k:=14 to 27 do spec_log[k]:=two_to_the[27-k]; 2707spec_log[28]:=1; 2708 2709@ Here is the routine that calculates $2^8$ times the natural logarithm 2710of a |scaled| quantity; it is an integer approximation to $2^{24}\ln(x/2^{16})$, 2711when |x| is a given positive integer. 2712 2713The method is based on exercise 1.2.2--25 in {\sl The Art of Computer 2714Programming\/}: During the main iteration we have $1\L 2^{-30}x<1/(1-2^{1-k})$, 2715and the logarithm of $2^{30}x$ remains to be added to an accumulator 2716register called~$y$. Three auxiliary bits of accuracy are retained in~$y$ 2717during the calculation, and sixteen auxiliary bits to extend |y| are 2718kept in~|z| during the initial argument reduction. (We add 2719$100\cdot2^{16}=6553600$ to~|z| and subtract 100 from~|y| so that |z| will 2720not become negative; also, the actual amount subtracted from~|y| is~96, 2721not~100, because we want to add~4 for rounding before the final division by~8.) 2722 2723@p function m_log(@!x:scaled):scaled; 2724var @!y,@!z:integer; {auxiliary registers} 2725@!k:integer; {iteration counter} 2726begin if x<=0 then @<Handle non-positive logarithm@> 2727else begin y:=1302456956+4-100; {$14\times2^{27}\ln2\approx1302456956.421063$} 2728 z:=27595+6553600; {and $2^{16}\times .421063\approx 27595$} 2729 while x<fraction_four do 2730 begin double(x); y:=y-93032639; z:=z-48782; 2731 end; {$2^{27}\ln2\approx 93032639.74436163$ 2732 and $2^{16}\times.74436163\approx 48782$} 2733 y:=y+(z div unity); k:=2; 2734 while x>fraction_four+4 do 2735 @<Increase |k| until |x| can be multiplied by a 2736 factor of $2^{-k}$, and adjust $y$ accordingly@>; 2737 m_log:=y div 8; 2738 end; 2739end; 2740 2741@ @<Increase |k| until |x| can...@>= 2742begin z:=((x-1) div two_to_the[k])+1; {$z=\lceil x/2^k\rceil$} 2743while x<fraction_four+z do 2744 begin z:=half(z+1); k:=k+1; 2745 end; 2746y:=y+spec_log[k]; x:=x-z; 2747end 2748 2749@ @<Handle non-positive logarithm@>= 2750begin print_err("Logarithm of "); 2751@.Logarithm...replaced by 0@> 2752print_scaled(x); print(" has been replaced by 0"); 2753help2("Since I don't take logs of non-positive numbers,")@/ 2754 ("I'm zeroing this one. Proceed, with fingers crossed."); 2755error; m_log:=0; 2756end 2757 2758@ Conversely, the exponential routine calculates $\exp(x/2^8)$, 2759when |x| is |scaled|. The result is an integer approximation to 2760$2^{16}\exp(x/2^{24})$, when |x| is regarded as an integer. 2761 2762@p function m_exp(@!x:scaled):scaled; 2763var @!k:small_number; {loop control index} 2764@!y,@!z:integer; {auxiliary registers} 2765begin if x>174436200 then 2766 {$2^{24}\ln((2^{31}-1)/2^{16})\approx 174436199.51$} 2767 begin arith_error:=true; m_exp:=el_gordo; 2768 end 2769else if x<-197694359 then m_exp:=0 2770 {$2^{24}\ln(2^{-1}/2^{16})\approx-197694359.45$} 2771else begin if x<=0 then 2772 begin z:=-8*x; y:=@'4000000; {$y=2^{20}$} 2773 end 2774 else begin if x<=127919879 then z:=1023359037-8*x 2775 {$2^{27}\ln((2^{31}-1)/2^{20})\approx 1023359037.125$} 2776 else z:=8*(174436200-x); {|z| is always nonnegative} 2777 y:=el_gordo; 2778 end; 2779 @<Multiply |y| by $\exp(-z/2^{27})$@>; 2780 if x<=127919879 then m_exp:=(y+8) div 16@+else m_exp:=y; 2781 end; 2782end; 2783 2784@ The idea here is that subtracting |spec_log[k]| from |z| corresponds 2785to multiplying |y| by $1-2^{-k}$. 2786 2787A subtle point (which had to be checked) was that if $x=127919879$, the 2788value of~|y| will decrease so that |y+8| doesn't overflow. In fact, 2789$z$ will be 5 in this case, and |y| will decrease by~64 when |k=25| 2790and by~16 when |k=27|. 2791 2792@<Multiply |y| by...@>= 2793k:=1; 2794while z>0 do 2795 begin while z>=spec_log[k] do 2796 begin z:=z-spec_log[k]; 2797 y:=y-1-((y-two_to_the[k-1]) div two_to_the[k]); 2798 end; 2799 incr(k); 2800 end 2801 2802@ The trigonometric subroutines use an auxiliary table such that 2803|spec_atan[k]| contains an approximation to the |angle| whose tangent 2804is~$1/2^k$. 2805 2806@<Glob...@>= 2807@!spec_atan:array[1..26] of angle; {$\arctan2^{-k}$ times $2^{20}\cdot180/\pi$} 2808 2809@ @<Set init...@>= 2810spec_atan[1]:=27855475; 2811spec_atan[2]:=14718068; 2812spec_atan[3]:=7471121; 2813spec_atan[4]:=3750058; 2814spec_atan[5]:=1876857; 2815spec_atan[6]:=938658; 2816spec_atan[7]:=469357; 2817spec_atan[8]:=234682; 2818spec_atan[9]:=117342; 2819spec_atan[10]:=58671; 2820spec_atan[11]:=29335; 2821spec_atan[12]:=14668; 2822spec_atan[13]:=7334; 2823spec_atan[14]:=3667; 2824spec_atan[15]:=1833; 2825spec_atan[16]:=917; 2826spec_atan[17]:=458; 2827spec_atan[18]:=229; 2828spec_atan[19]:=115; 2829spec_atan[20]:=57; 2830spec_atan[21]:=29; 2831spec_atan[22]:=14; 2832spec_atan[23]:=7; 2833spec_atan[24]:=4; 2834spec_atan[25]:=2; 2835spec_atan[26]:=1; 2836 2837@ Given integers |x| and |y|, not both zero, the |n_arg| function 2838returns the |angle| whose tangent points in the direction $(x,y)$. 2839This subroutine first determines the correct octant, then solves the 2840problem for |0<=y<=x|, then converts the result appropriately to 2841return an answer in the range |-one_eighty_deg<=@t$\theta$@><=one_eighty_deg|. 2842(The answer is |+one_eighty_deg| if |y=0| and |x<0|, but an answer of 2843|-one_eighty_deg| is possible if, for example, |y=-1| and $x=-2^{30}$.) 2844 2845The octants are represented in a ``Gray code,'' since that turns out 2846to be computationally simplest. 2847 2848@d negate_x=1 2849@d negate_y=2 2850@d switch_x_and_y=4 2851@d first_octant=1 2852@d second_octant=first_octant+switch_x_and_y 2853@d third_octant=first_octant+switch_x_and_y+negate_x 2854@d fourth_octant=first_octant+negate_x 2855@d fifth_octant=first_octant+negate_x+negate_y 2856@d sixth_octant=first_octant+switch_x_and_y+negate_x+negate_y 2857@d seventh_octant=first_octant+switch_x_and_y+negate_y 2858@d eighth_octant=first_octant+negate_y 2859 2860@p function n_arg(@!x,@!y:integer):angle; 2861var @!z:angle; {auxiliary register} 2862@!t:integer; {temporary storage} 2863@!k:small_number; {loop counter} 2864@!octant:first_octant..sixth_octant; {octant code} 2865begin if x>=0 then octant:=first_octant 2866else begin negate(x); octant:=first_octant+negate_x; 2867 end; 2868if y<0 then 2869 begin negate(y); octant:=octant+negate_y; 2870 end; 2871if x<y then 2872 begin t:=y; y:=x; x:=t; octant:=octant+switch_x_and_y; 2873 end; 2874if x=0 then @<Handle undefined arg@> 2875else begin @<Set variable |z| to the arg of $(x,y)$@>; 2876 @<Return an appropriate answer based on |z| and |octant|@>; 2877 end; 2878end; 2879 2880@ @<Handle undefined arg@>= 2881begin print_err("angle(0,0) is taken as zero"); 2882@.angle(0,0)...zero@> 2883help2("The `angle' between two identical points is undefined.")@/ 2884 ("I'm zeroing this one. Proceed, with fingers crossed."); 2885error; n_arg:=0; 2886end 2887 2888@ @<Return an appropriate answer...@>= 2889case octant of 2890first_octant:n_arg:=z; 2891second_octant:n_arg:=ninety_deg-z; 2892third_octant:n_arg:=ninety_deg+z; 2893fourth_octant:n_arg:=one_eighty_deg-z; 2894fifth_octant:n_arg:=z-one_eighty_deg; 2895sixth_octant:n_arg:=-z-ninety_deg; 2896seventh_octant:n_arg:=z-ninety_deg; 2897eighth_octant:n_arg:=-z; 2898end {there are no other cases} 2899 2900@ At this point we have |x>=y>=0|, and |x>0|. The numbers are scaled up 2901or down until $2^{28}\L x<2^{29}$, so that accurate fixed-point calculations 2902will be made. 2903 2904@<Set variable |z| to the arg...@>= 2905while x>=fraction_two do 2906 begin x:=half(x); y:=half(y); 2907 end; 2908z:=0; 2909if y>0 then 2910 begin while x<fraction_one do 2911 begin double(x); double(y); 2912 end; 2913 @<Increase |z| to the arg of $(x,y)$@>; 2914 end 2915 2916@ During the calculations of this section, variables |x| and~|y| 2917represent actual coordinates $(x,2^{-k}y)$. We will maintain the 2918condition |x>=y|, so that the tangent will be at most $2^{-k}$. 2919If $x<2y$, the tangent is greater than $2^{-k-1}$. The transformation 2920$(a,b)\mapsto(a+b\tan\phi,b-a\tan\phi)$ replaces $(a,b)$ by 2921coordinates whose angle has decreased by~$\phi$; in the special case 2922$a=x$, $b=2^{-k}y$, and $\tan\phi=2^{-k-1}$, this operation reduces 2923to the particularly simple iteration shown here. [Cf.~John E. Meggitt, 2924@^Meggitt, John E.@> 2925{\sl IBM Journal of Research and Development\/ \bf6} (1962), 210--226.] 2926 2927The initial value of |x| will be multiplied by at most 2928$(1+{1\over2})(1+{1\over8})(1+{1\over32})\cdots\approx 1.7584$; hence 2929there is no chance of integer overflow. 2930 2931@<Increase |z|...@>= 2932k:=0; 2933repeat double(y); incr(k); 2934if y>x then 2935 begin z:=z+spec_atan[k]; t:=x; x:=x+(y div two_to_the[k+k]); y:=y-t; 2936 end; 2937until k=15; 2938repeat double(y); incr(k); 2939if y>x then 2940 begin z:=z+spec_atan[k]; y:=y-x; 2941 end; 2942until k=26 2943 2944@ Conversely, the |n_sin_cos| routine takes an |angle| and produces the sine 2945and cosine of that angle. The results of this routine are 2946stored in global integer variables |n_sin| and |n_cos|. 2947 2948@<Glob...@>= 2949@!n_sin,@!n_cos:fraction; {results computed by |n_sin_cos|} 2950 2951@ Given an integer |z| that is $2^{20}$ times an angle $\theta$ in degrees, 2952the purpose of |n_sin_cos(z)| is to set 2953|x=@t$r\cos\theta$@>| and |y=@t$r\sin\theta$@>| (approximately), 2954for some rather large number~|r|. The maximum of |x| and |y| 2955will be between $2^{28}$ and $2^{30}$, so that there will be hardly 2956any loss of accuracy. Then |x| and~|y| are divided by~|r|. 2957 2958@p procedure n_sin_cos(@!z:angle); {computes a multiple of the sine and cosine} 2959var @!k:small_number; {loop control variable} 2960@!q:0..7; {specifies the quadrant} 2961@!r:fraction; {magnitude of |(x,y)|} 2962@!x,@!y,@!t:integer; {temporary registers} 2963begin while z<0 do z:=z+three_sixty_deg; 2964z:=z mod three_sixty_deg; {now |0<=z<three_sixty_deg|} 2965q:=z div forty_five_deg; z:=z mod forty_five_deg; 2966x:=fraction_one; y:=x; 2967if not odd(q) then z:=forty_five_deg-z; 2968@<Subtract angle |z| from |(x,y)|@>; 2969@<Convert |(x,y)| to the octant determined by~|q|@>; 2970r:=pyth_add(x,y); n_cos:=make_fraction(x,r); n_sin:=make_fraction(y,r); 2971end; 2972 2973@ In this case the octants are numbered sequentially. 2974 2975@<Convert |(x,...@>= 2976case q of 29770:do_nothing; 29781:begin t:=x; x:=y; y:=t; 2979 end; 29802:begin t:=x; x:=-y; y:=t; 2981 end; 29823:negate(x); 29834:begin negate(x); negate(y); 2984 end; 29855:begin t:=x; x:=-y; y:=-t; 2986 end; 29876:begin t:=x; x:=y; y:=-t; 2988 end; 29897:negate(y); 2990end {there are no other cases} 2991 2992@ The main iteration of |n_sin_cos| is similar to that of |n_arg| but 2993applied in reverse. The values of |spec_atan[k]| decrease slowly enough 2994that this loop is guaranteed to terminate before the (nonexistent) value 2995|spec_atan[27]| would be required. 2996 2997@<Subtract angle |z|...@>= 2998k:=1; 2999while z>0 do 3000 begin if z>=spec_atan[k] then 3001 begin z:=z-spec_atan[k]; t:=x;@/ 3002 x:=t+y div two_to_the[k]; 3003 y:=y-t div two_to_the[k]; 3004 end; 3005 incr(k); 3006 end; 3007if y<0 then y:=0 {this precaution may never be needed} 3008 3009@ And now let's complete our collection of numeric utility routines 3010by considering random number generation. 3011\MF\ generates pseudo-random numbers with the additive scheme recommended 3012in Section 3.6 of {\sl The Art of Computer Programming}; however, the 3013results are random fractions between 0 and |fraction_one-1|, inclusive. 3014 3015There's an auxiliary array |randoms| that contains 55 pseudo-random 3016fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-24})\bmod 2^{28}$, 3017we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|. 3018The global variable |j_random| tells which element has most recently 3019been consumed. 3020 3021@<Glob...@>= 3022@!randoms:array[0..54] of fraction; {the last 55 random values generated} 3023@!j_random:0..54; {the number of unused |randoms|} 3024 3025@ To consume a random fraction, the program below will say `|next_random|' 3026and then it will fetch |randoms[j_random]|. The |next_random| macro 3027actually accesses the numbers backwards; blocks of 55~$x$'s are 3028essentially being ``flipped.'' But that doesn't make them less random. 3029 3030@d next_random==if j_random=0 then new_randoms 3031 else decr(j_random) 3032 3033@p procedure new_randoms; 3034var @!k:0..54; {index into |randoms|} 3035@!x:fraction; {accumulator} 3036begin for k:=0 to 23 do 3037 begin x:=randoms[k]-randoms[k+31]; 3038 if x<0 then x:=x+fraction_one; 3039 randoms[k]:=x; 3040 end; 3041for k:=24 to 54 do 3042 begin x:=randoms[k]-randoms[k-24]; 3043 if x<0 then x:=x+fraction_one; 3044 randoms[k]:=x; 3045 end; 3046j_random:=54; 3047end; 3048 3049@ To initialize the |randoms| table, we call the following routine. 3050 3051@p procedure init_randoms(@!seed:scaled); 3052var @!j,@!jj,@!k:fraction; {more or less random integers} 3053@!i:0..54; {index into |randoms|} 3054begin j:=abs(seed); 3055while j>=fraction_one do j:=half(j); 3056k:=1; 3057for i:=0 to 54 do 3058 begin jj:=k; k:=j-k; j:=jj; 3059 if k<0 then k:=k+fraction_one; 3060 randoms[(i*21)mod 55]:=j; 3061 end; 3062new_randoms; new_randoms; new_randoms; {``warm up'' the array} 3063end; 3064 3065@ To produce a uniform random number in the range |0<=u<x| or |0>=u>x| 3066or |0=u=x|, given a |scaled| value~|x|, we proceed as shown here. 3067 3068Note that the call of |take_fraction| will produce the values 0 and~|x| 3069with about half the probability that it will produce any other particular 3070values between 0 and~|x|, because it rounds its answers. 3071 3072@p function unif_rand(@!x:scaled):scaled; 3073var @!y:scaled; {trial value} 3074begin next_random; y:=take_fraction(abs(x),randoms[j_random]); 3075if y=abs(x) then unif_rand:=0 3076else if x>0 then unif_rand:=y 3077else unif_rand:=-y; 3078end; 3079 3080@ Finally, a normal deviate with mean zero and unit standard deviation 3081can readily be obtained with the ratio method (Algorithm 3.4.1R in 3082{\sl The Art of Computer Programming\/}). 3083 3084@p function norm_rand:scaled; 3085var @!x,@!u,@!l:integer; {what the book would call $2^{16}X$, $2^{28}U$, 3086 and $-2^{24}\ln U$} 3087begin repeat 3088 repeat next_random; 3089 x:=take_fraction(112429,randoms[j_random]-fraction_half); 3090 {$2^{16}\sqrt{8/e}\approx 112428.82793$} 3091 next_random; u:=randoms[j_random]; 3092 until abs(x)<u; 3093x:=make_fraction(x,u); 3094l:=139548960-m_log(u); {$2^{24}\cdot12\ln2\approx139548959.6165$} 3095until ab_vs_cd(1024,l,x,x)>=0; 3096norm_rand:=x; 3097end; 3098 3099@* \[9] Packed data. 3100In order to make efficient use of storage space, \MF\ bases its major data 3101structures on a |memory_word|, which contains either a (signed) integer, 3102possibly scaled, or a small number of fields that are one half or one 3103quarter of the size used for storing integers. 3104 3105If |x| is a variable of type |memory_word|, it contains up to four 3106fields that can be referred to as follows: 3107$$\vbox{\halign{\hfil#&#\hfil&#\hfil\cr 3108|x|&.|int|&(an |integer|)\cr 3109|x|&.|sc|\qquad&(a |scaled| integer)\cr 3110|x.hh.lh|, |x.hh|&.|rh|&(two halfword fields)\cr 3111|x.hh.b0|, |x.hh.b1|, |x.hh|&.|rh|&(two quarterword fields, one halfword 3112 field)\cr 3113|x.qqqq.b0|, |x.qqqq.b1|, |x.qqqq|&.|b2|, |x.qqqq.b3|\hskip-100pt 3114 &\qquad\qquad\qquad(four quarterword fields)\cr}}$$ 3115This is somewhat cumbersome to write, and not very readable either, but 3116macros will be used to make the notation shorter and more transparent. 3117The \PASCAL\ code below gives a formal definition of |memory_word| and 3118its subsidiary types, using packed variant records. \MF\ makes no 3119assumptions about the relative positions of the fields within a word. 3120 3121Since we are assuming 32-bit integers, a halfword must contain at least 312216 bits, and a quarterword must contain at least 8 bits. 3123@^system dependencies@> 3124But it doesn't hurt to have more bits; for example, with enough 36-bit 3125words you might be able to have |mem_max| as large as 262142. 3126 3127N.B.: Valuable memory space will be dreadfully wasted unless \MF\ is compiled 3128by a \PASCAL\ that packs all of the |memory_word| variants into 3129the space of a single integer. Some \PASCAL\ compilers will pack an 3130integer whose subrange is `|0..255|' into an eight-bit field, but others 3131insist on allocating space for an additional sign bit; on such systems you 3132can get 256 values into a quarterword only if the subrange is `|-128..127|'. 3133 3134The present implementation tries to accommodate as many variations as possible, 3135so it makes few assumptions. If integers having the subrange 3136`|min_quarterword..max_quarterword|' can be packed into a quarterword, 3137and if integers having the subrange `|min_halfword..max_halfword|' 3138can be packed into a halfword, everything should work satisfactorily. 3139 3140It is usually most efficient to have |min_quarterword=min_halfword=0|, 3141so one should try to achieve this unless it causes a severe problem. 3142The values defined here are recommended for most 32-bit computers. 3143 3144@d min_quarterword=0 {smallest allowable value in a |quarterword|} 3145@d max_quarterword=255 {largest allowable value in a |quarterword|} 3146@d min_halfword==0 {smallest allowable value in a |halfword|} 3147@d max_halfword==65535 {largest allowable value in a |halfword|} 3148 3149@ Here are the inequalities that the quarterword and halfword values 3150must satisfy (or rather, the inequalities that they mustn't satisfy): 3151 3152@<Check the ``constant''...@>= 3153init if mem_max<>mem_top then bad:=10;@+tini@;@/ 3154if mem_max<mem_top then bad:=10; 3155if (min_quarterword>0)or(max_quarterword<127) then bad:=11; 3156if (min_halfword>0)or(max_halfword<32767) then bad:=12; 3157if (min_quarterword<min_halfword)or@| 3158 (max_quarterword>max_halfword) then bad:=13; 3159if (mem_min<min_halfword)or(mem_max>=max_halfword) then bad:=14; 3160if max_strings>max_halfword then bad:=15; 3161if buf_size>max_halfword then bad:=16; 3162if (max_quarterword-min_quarterword<255)or@| 3163 (max_halfword-min_halfword<65535) then bad:=17; 3164 3165@ The operation of subtracting |min_halfword| occurs rather frequently in 3166\MF, so it is convenient to abbreviate this operation by using the macro 3167|ho| defined here. \MF\ will run faster with respect to compilers that 3168don't optimize the expression `|x-0|', if this macro is simplified in the 3169obvious way when |min_halfword=0|. Similarly, |qi| and |qo| are used for 3170input to and output from quarterwords. 3171@^system dependencies@> 3172 3173@d ho(#)==#-min_halfword 3174 {to take a sixteen-bit item from a halfword} 3175@d qo(#)==#-min_quarterword {to read eight bits from a quarterword} 3176@d qi(#)==#+min_quarterword {to store eight bits in a quarterword} 3177 3178@ The reader should study the following definitions closely: 3179@^system dependencies@> 3180 3181@d sc==int {|scaled| data is equivalent to |integer|} 3182 3183@<Types...@>= 3184@!quarterword = min_quarterword..max_quarterword; {1/4 of a word} 3185@!halfword=min_halfword..max_halfword; {1/2 of a word} 3186@!two_choices = 1..2; {used when there are two variants in a record} 3187@!three_choices = 1..3; {used when there are three variants in a record} 3188@!two_halves = packed record@;@/ 3189 @!rh:halfword; 3190 case two_choices of 3191 1: (@!lh:halfword); 3192 2: (@!b0:quarterword; @!b1:quarterword); 3193 end; 3194@!four_quarters = packed record@;@/ 3195 @!b0:quarterword; 3196 @!b1:quarterword; 3197 @!b2:quarterword; 3198 @!b3:quarterword; 3199 end; 3200@!memory_word = record@;@/ 3201 case three_choices of 3202 1: (@!int:integer); 3203 2: (@!hh:two_halves); 3204 3: (@!qqqq:four_quarters); 3205 end; 3206@!word_file = file of memory_word; 3207 3208@ When debugging, we may want to print a |memory_word| without knowing 3209what type it is; so we print it in all modes. 3210@^dirty \PASCAL@>@^debugging@> 3211 3212@p @!debug procedure print_word(@!w:memory_word); 3213 {prints |w| in all ways} 3214begin print_int(w.int); print_char(" ");@/ 3215print_scaled(w.sc); print_char(" "); print_scaled(w.sc div @'10000); print_ln;@/ 3216print_int(w.hh.lh); print_char("="); print_int(w.hh.b0); print_char(":"); 3217print_int(w.hh.b1); print_char(";"); print_int(w.hh.rh); print_char(" ");@/ 3218print_int(w.qqqq.b0); print_char(":"); print_int(w.qqqq.b1); print_char(":"); 3219print_int(w.qqqq.b2); print_char(":"); print_int(w.qqqq.b3); 3220end; 3221gubed 3222 3223@* \[10] Dynamic memory allocation. 3224The \MF\ system does nearly all of its own memory allocation, so that it 3225can readily be transported into environments that do not have automatic 3226facilities for strings, garbage collection, etc., and so that it can be in 3227control of what error messages the user receives. The dynamic storage 3228requirements of \MF\ are handled by providing a large array |mem| in 3229which consecutive blocks of words are used as nodes by the \MF\ routines. 3230 3231Pointer variables are indices into this array, or into another array 3232called |eqtb| that will be explained later. A pointer variable might 3233also be a special flag that lies outside the bounds of |mem|, so we 3234allow pointers to assume any |halfword| value. The minimum memory 3235index represents a null pointer. 3236 3237@d pointer==halfword {a flag or a location in |mem| or |eqtb|} 3238@d null==mem_min {the null pointer} 3239 3240@ The |mem| array is divided into two regions that are allocated separately, 3241but the dividing line between these two regions is not fixed; they grow 3242together until finding their ``natural'' size in a particular job. 3243Locations less than or equal to |lo_mem_max| are used for storing 3244variable-length records consisting of two or more words each. This region 3245is maintained using an algorithm similar to the one described in exercise 32462.5--19 of {\sl The Art of Computer Programming}. However, no size field 3247appears in the allocated nodes; the program is responsible for knowing the 3248relevant size when a node is freed. Locations greater than or equal to 3249|hi_mem_min| are used for storing one-word records; a conventional 3250\.{AVAIL} stack is used for allocation in this region. 3251 3252Locations of |mem| between |mem_min| and |mem_top| may be dumped as part 3253of preloaded base files, by the \.{INIMF} preprocessor. 3254@.INIMF@> 3255Production versions of \MF\ may extend the memory at the top end in order to 3256provide more space; these locations, between |mem_top| and |mem_max|, 3257are always used for single-word nodes. 3258 3259The key pointers that govern |mem| allocation have a prescribed order: 3260$$\hbox{|null=mem_min<lo_mem_max<hi_mem_min<mem_top<=mem_end<=mem_max|.}$$ 3261 3262@<Glob...@>= 3263@!mem : array[mem_min..mem_max] of memory_word; {the big dynamic storage area} 3264@!lo_mem_max : pointer; {the largest location of variable-size memory in use} 3265@!hi_mem_min : pointer; {the smallest location of one-word memory in use} 3266 3267@ Users who wish to study the memory requirements of specific applications can 3268use optional special features that keep track of current and 3269maximum memory usage. When code between the delimiters |@!stat| $\ldots$ 3270|tats| is not ``commented out,'' \MF\ will run a bit slower but it will 3271report these statistics when |tracing_stats| is positive. 3272 3273@<Glob...@>= 3274@!var_used, @!dyn_used : integer; {how much memory is in use} 3275 3276@ Let's consider the one-word memory region first, since it's the 3277simplest. The pointer variable |mem_end| holds the highest-numbered location 3278of |mem| that has ever been used. The free locations of |mem| that 3279occur between |hi_mem_min| and |mem_end|, inclusive, are of type 3280|two_halves|, and we write |info(p)| and |link(p)| for the |lh| 3281and |rh| fields of |mem[p]| when it is of this type. The single-word 3282free locations form a linked list 3283$$|avail|,\;\hbox{|link(avail)|},\;\hbox{|link(link(avail))|},\;\ldots$$ 3284terminated by |null|. 3285 3286@d link(#) == mem[#].hh.rh {the |link| field of a memory word} 3287@d info(#) == mem[#].hh.lh {the |info| field of a memory word} 3288 3289@<Glob...@>= 3290@!avail : pointer; {head of the list of available one-word nodes} 3291@!mem_end : pointer; {the last one-word node used in |mem|} 3292 3293@ If one-word memory is exhausted, it might mean that the user has forgotten 3294a token like `\&{enddef}' or `\&{endfor}'. We will define some procedures 3295later that try to help pinpoint the trouble. 3296 3297@p @t\4@>@<Declare the procedure called |show_token_list|@>@; 3298@t\4@>@<Declare the procedure called |runaway|@> 3299 3300@ The function |get_avail| returns a pointer to a new one-word node whose 3301|link| field is null. However, \MF\ will halt if there is no more room left. 3302@^inner loop@> 3303 3304@p function get_avail : pointer; {single-word node allocation} 3305var @!p:pointer; {the new node being got} 3306begin p:=avail; {get top location in the |avail| stack} 3307if p<>null then avail:=link(avail) {and pop it off} 3308else if mem_end<mem_max then {or go into virgin territory} 3309 begin incr(mem_end); p:=mem_end; 3310 end 3311else begin decr(hi_mem_min); p:=hi_mem_min; 3312 if hi_mem_min<=lo_mem_max then 3313 begin runaway; {if memory is exhausted, display possible runaway text} 3314 overflow("main memory size",mem_max+1-mem_min); 3315 {quit; all one-word nodes are busy} 3316@:METAFONT capacity exceeded main memory size}{\quad main memory size@> 3317 end; 3318 end; 3319link(p):=null; {provide an oft-desired initialization of the new node} 3320@!stat incr(dyn_used);@+tats@;{maintain statistics} 3321get_avail:=p; 3322end; 3323 3324@ Conversely, a one-word node is recycled by calling |free_avail|. 3325 3326@d free_avail(#)== {single-word node liberation} 3327 begin link(#):=avail; avail:=#; 3328 @!stat decr(dyn_used);@+tats@/ 3329 end 3330 3331@ There's also a |fast_get_avail| routine, which saves the procedure-call 3332overhead at the expense of extra programming. This macro is used in 3333the places that would otherwise account for the most calls of |get_avail|. 3334@^inner loop@> 3335 3336@d fast_get_avail(#)==@t@>@;@/ 3337 begin #:=avail; {avoid |get_avail| if possible, to save time} 3338 if #=null then #:=get_avail 3339 else begin avail:=link(#); link(#):=null; 3340 @!stat incr(dyn_used);@+tats@/ 3341 end; 3342 end 3343 3344@ The available-space list that keeps track of the variable-size portion 3345of |mem| is a nonempty, doubly-linked circular list of empty nodes, 3346pointed to by the roving pointer |rover|. 3347 3348Each empty node has size 2 or more; the first word contains the special 3349value |max_halfword| in its |link| field and the size in its |info| field; 3350the second word contains the two pointers for double linking. 3351 3352Each nonempty node also has size 2 or more. Its first word is of type 3353|two_halves|\kern-1pt, and its |link| field is never equal to |max_halfword|. 3354Otherwise there is complete flexibility with respect to the contents 3355of its other fields and its other words. 3356 3357(We require |mem_max<max_halfword| because terrible things can happen 3358when |max_halfword| appears in the |link| field of a nonempty node.) 3359 3360@d empty_flag == max_halfword {the |link| of an empty variable-size node} 3361@d is_empty(#) == (link(#)=empty_flag) {tests for empty node} 3362@d node_size == info {the size field in empty variable-size nodes} 3363@d llink(#) == info(#+1) {left link in doubly-linked list of empty nodes} 3364@d rlink(#) == link(#+1) {right link in doubly-linked list of empty nodes} 3365 3366@<Glob...@>= 3367@!rover : pointer; {points to some node in the list of empties} 3368 3369@ A call to |get_node| with argument |s| returns a pointer to a new node 3370of size~|s|, which must be 2~or more. The |link| field of the first word 3371of this new node is set to null. An overflow stop occurs if no suitable 3372space exists. 3373 3374If |get_node| is called with $s=2^{30}$, it simply merges adjacent free 3375areas and returns the value |max_halfword|. 3376 3377@p function get_node(@!s:integer):pointer; {variable-size node allocation} 3378label found,exit,restart; 3379var @!p:pointer; {the node currently under inspection} 3380@!q:pointer; {the node physically after node |p|} 3381@!r:integer; {the newly allocated node, or a candidate for this honor} 3382@!t,@!tt:integer; {temporary registers} 3383@^inner loop@> 3384begin restart: p:=rover; {start at some free node in the ring} 3385repeat @<Try to allocate within node |p| and its physical successors, 3386 and |goto found| if allocation was possible@>; 3387p:=rlink(p); {move to the next node in the ring} 3388until p=rover; {repeat until the whole list has been traversed} 3389if s=@'10000000000 then 3390 begin get_node:=max_halfword; return; 3391 end; 3392if lo_mem_max+2<hi_mem_min then if lo_mem_max+2<=mem_min+max_halfword then 3393 @<Grow more variable-size memory and |goto restart|@>; 3394overflow("main memory size",mem_max+1-mem_min); 3395 {sorry, nothing satisfactory is left} 3396@:METAFONT capacity exceeded main memory size}{\quad main memory size@> 3397found: link(r):=null; {this node is now nonempty} 3398@!stat var_used:=var_used+s; {maintain usage statistics} 3399tats@;@/ 3400get_node:=r; 3401exit:end; 3402 3403@ The lower part of |mem| grows by 1000 words at a time, unless 3404we are very close to going under. When it grows, we simply link 3405a new node into the available-space list. This method of controlled 3406growth helps to keep the |mem| usage consecutive when \MF\ is 3407implemented on ``virtual memory'' systems. 3408@^virtual memory@> 3409 3410@<Grow more variable-size memory and |goto restart|@>= 3411begin if hi_mem_min-lo_mem_max>=1998 then t:=lo_mem_max+1000 3412else t:=lo_mem_max+1+(hi_mem_min-lo_mem_max) div 2; 3413 {|lo_mem_max+2<=t<hi_mem_min|} 3414if t>mem_min+max_halfword then t:=mem_min+max_halfword; 3415p:=llink(rover); q:=lo_mem_max; rlink(p):=q; llink(rover):=q;@/ 3416rlink(q):=rover; llink(q):=p; link(q):=empty_flag; node_size(q):=t-lo_mem_max;@/ 3417lo_mem_max:=t; link(lo_mem_max):=null; info(lo_mem_max):=null; 3418rover:=q; goto restart; 3419end 3420 3421@ @<Try to allocate...@>= 3422q:=p+node_size(p); {find the physical successor} 3423while is_empty(q) do {merge node |p| with node |q|} 3424 begin t:=rlink(q); tt:=llink(q); 3425@^inner loop@> 3426 if q=rover then rover:=t; 3427 llink(t):=tt; rlink(tt):=t;@/ 3428 q:=q+node_size(q); 3429 end; 3430r:=q-s; 3431if r>p+1 then @<Allocate from the top of node |p| and |goto found|@>; 3432if r=p then if rlink(p)<>p then 3433 @<Allocate entire node |p| and |goto found|@>; 3434node_size(p):=q-p {reset the size in case it grew} 3435 3436@ @<Allocate from the top...@>= 3437begin node_size(p):=r-p; {store the remaining size} 3438rover:=p; {start searching here next time} 3439goto found; 3440end 3441 3442@ Here we delete node |p| from the ring, and let |rover| rove around. 3443 3444@<Allocate entire...@>= 3445begin rover:=rlink(p); t:=llink(p); 3446llink(rover):=t; rlink(t):=rover; 3447goto found; 3448end 3449 3450@ Conversely, when some variable-size node |p| of size |s| is no longer needed, 3451the operation |free_node(p,s)| will make its words available, by inserting 3452|p| as a new empty node just before where |rover| now points. 3453 3454@p procedure free_node(@!p:pointer; @!s:halfword); {variable-size node 3455 liberation} 3456var @!q:pointer; {|llink(rover)|} 3457begin node_size(p):=s; link(p):=empty_flag; 3458@^inner loop@> 3459q:=llink(rover); llink(p):=q; rlink(p):=rover; {set both links} 3460llink(rover):=p; rlink(q):=p; {insert |p| into the ring} 3461@!stat var_used:=var_used-s;@+tats@;{maintain statistics} 3462end; 3463 3464@ Just before \.{INIMF} writes out the memory, it sorts the doubly linked 3465available space list. The list is probably very short at such times, so a 3466simple insertion sort is used. The smallest available location will be 3467pointed to by |rover|, the next-smallest by |rlink(rover)|, etc. 3468 3469@p @!init procedure sort_avail; {sorts the available variable-size nodes 3470 by location} 3471var @!p,@!q,@!r: pointer; {indices into |mem|} 3472@!old_rover:pointer; {initial |rover| setting} 3473begin p:=get_node(@'10000000000); {merge adjacent free areas} 3474p:=rlink(rover); rlink(rover):=max_halfword; old_rover:=rover; 3475while p<>old_rover do @<Sort |p| into the list starting at |rover| 3476 and advance |p| to |rlink(p)|@>; 3477p:=rover; 3478while rlink(p)<>max_halfword do 3479 begin llink(rlink(p)):=p; p:=rlink(p); 3480 end; 3481rlink(p):=rover; llink(rover):=p; 3482end; 3483tini 3484 3485@ The following |while| loop is guaranteed to 3486terminate, since the list that starts at 3487|rover| ends with |max_halfword| during the sorting procedure. 3488 3489@<Sort |p|...@>= 3490if p<rover then 3491 begin q:=p; p:=rlink(q); rlink(q):=rover; rover:=q; 3492 end 3493else begin q:=rover; 3494 while rlink(q)<p do q:=rlink(q); 3495 r:=rlink(p); rlink(p):=rlink(q); rlink(q):=p; p:=r; 3496 end 3497 3498@* \[11] Memory layout. 3499Some areas of |mem| are dedicated to fixed usage, since static allocation is 3500more efficient than dynamic allocation when we can get away with it. For 3501example, locations |mem_min| to |mem_min+2| are always used to store the 3502specification for null pen coordinates that are `$(0,0)$'. The 3503following macro definitions accomplish the static allocation by giving 3504symbolic names to the fixed positions. Static variable-size nodes appear 3505in locations |mem_min| through |lo_mem_stat_max|, and static single-word nodes 3506appear in locations |hi_mem_stat_min| through |mem_top|, inclusive. 3507 3508@d null_coords==mem_min {specification for pen offsets of $(0,0)$} 3509@d null_pen==null_coords+3 {we will define |coord_node_size=3|} 3510@d dep_head==null_pen+10 {and |pen_node_size=10|} 3511@d zero_val==dep_head+2 {two words for a permanently zero value} 3512@d temp_val==zero_val+2 {two words for a temporary value node} 3513@d end_attr==temp_val {we use |end_attr+2| only} 3514@d inf_val==end_attr+2 {and |inf_val+1| only} 3515@d bad_vardef==inf_val+2 {two words for \&{vardef} error recovery} 3516@d lo_mem_stat_max==bad_vardef+1 {largest statically 3517 allocated word in the variable-size |mem|} 3518@# 3519@d sentinel==mem_top {end of sorted lists} 3520@d temp_head==mem_top-1 {head of a temporary list of some kind} 3521@d hold_head==mem_top-2 {head of a temporary list of another kind} 3522@d hi_mem_stat_min==mem_top-2 {smallest statically allocated word in 3523 the one-word |mem|} 3524 3525@ The following code gets the dynamic part of |mem| off to a good start, 3526when \MF\ is initializing itself the slow way. 3527 3528@<Initialize table entries (done by \.{INIMF} only)@>= 3529rover:=lo_mem_stat_max+1; {initialize the dynamic memory} 3530link(rover):=empty_flag; 3531node_size(rover):=1000; {which is a 1000-word available node} 3532llink(rover):=rover; rlink(rover):=rover;@/ 3533lo_mem_max:=rover+1000; link(lo_mem_max):=null; info(lo_mem_max):=null;@/ 3534for k:=hi_mem_stat_min to mem_top do 3535 mem[k]:=mem[lo_mem_max]; {clear list heads} 3536avail:=null; mem_end:=mem_top; 3537hi_mem_min:=hi_mem_stat_min; {initialize the one-word memory} 3538var_used:=lo_mem_stat_max+1-mem_min; dyn_used:=mem_top+1-hi_mem_min; 3539 {initialize statistics} 3540 3541@ The procedure |flush_list(p)| frees an entire linked list of one-word 3542nodes that starts at a given position, until coming to |sentinel| or a 3543pointer that is not in the one-word region. Another procedure, 3544|flush_node_list|, frees an entire linked list of one-word and two-word 3545nodes, until coming to a |null| pointer. 3546@^inner loop@> 3547 3548@p procedure flush_list(@!p:pointer); {makes list of single-word nodes 3549 available} 3550label done; 3551var @!q,@!r:pointer; {list traversers} 3552begin if p>=hi_mem_min then if p<>sentinel then 3553 begin r:=p; 3554 repeat q:=r; r:=link(r); @!stat decr(dyn_used);@+tats@/ 3555 if r<hi_mem_min then goto done; 3556 until r=sentinel; 3557 done: {now |q| is the last node on the list} 3558 link(q):=avail; avail:=p; 3559 end; 3560end; 3561@# 3562procedure flush_node_list(@!p:pointer); 3563var @!q:pointer; {the node being recycled} 3564begin while p<>null do 3565 begin q:=p; p:=link(p); 3566 if q<hi_mem_min then free_node(q,2)@+else free_avail(q); 3567 end; 3568end; 3569 3570@ If \MF\ is extended improperly, the |mem| array might get screwed up. 3571For example, some pointers might be wrong, or some ``dead'' nodes might not 3572have been freed when the last reference to them disappeared. Procedures 3573|check_mem| and |search_mem| are available to help diagnose such 3574problems. These procedures make use of two arrays called |free| and 3575|was_free| that are present only if \MF's debugging routines have 3576been included. (You may want to decrease the size of |mem| while you 3577@^debugging@> 3578are debugging.) 3579 3580@<Glob...@>= 3581@!debug @!free: packed array [mem_min..mem_max] of boolean; {free cells} 3582@t\hskip1em@>@!was_free: packed array [mem_min..mem_max] of boolean; 3583 {previously free cells} 3584@t\hskip1em@>@!was_mem_end,@!was_lo_max,@!was_hi_min: pointer; 3585 {previous |mem_end|, |lo_mem_max|, and |hi_mem_min|} 3586@t\hskip1em@>@!panicking:boolean; {do we want to check memory constantly?} 3587gubed 3588 3589@ @<Set initial...@>= 3590@!debug was_mem_end:=mem_min; {indicate that everything was previously free} 3591was_lo_max:=mem_min; was_hi_min:=mem_max; 3592panicking:=false; 3593gubed 3594 3595@ Procedure |check_mem| makes sure that the available space lists of 3596|mem| are well formed, and it optionally prints out all locations 3597that are reserved now but were free the last time this procedure was called. 3598 3599@p @!debug procedure check_mem(@!print_locs : boolean); 3600label done1,done2; {loop exits} 3601var @!p,@!q,@!r:pointer; {current locations of interest in |mem|} 3602@!clobbered:boolean; {is something amiss?} 3603begin for p:=mem_min to lo_mem_max do free[p]:=false; {you can probably 3604 do this faster} 3605for p:=hi_mem_min to mem_end do free[p]:=false; {ditto} 3606@<Check single-word |avail| list@>; 3607@<Check variable-size |avail| list@>; 3608@<Check flags of unavailable nodes@>; 3609@<Check the list of linear dependencies@>; 3610if print_locs then @<Print newly busy locations@>; 3611for p:=mem_min to lo_mem_max do was_free[p]:=free[p]; 3612for p:=hi_mem_min to mem_end do was_free[p]:=free[p]; 3613 {|was_free:=free| might be faster} 3614was_mem_end:=mem_end; was_lo_max:=lo_mem_max; was_hi_min:=hi_mem_min; 3615end; 3616gubed 3617 3618@ @<Check single-word...@>= 3619p:=avail; q:=null; clobbered:=false; 3620while p<>null do 3621 begin if (p>mem_end)or(p<hi_mem_min) then clobbered:=true 3622 else if free[p] then clobbered:=true; 3623 if clobbered then 3624 begin print_nl("AVAIL list clobbered at "); 3625@.AVAIL list clobbered...@> 3626 print_int(q); goto done1; 3627 end; 3628 free[p]:=true; q:=p; p:=link(q); 3629 end; 3630done1: 3631 3632@ @<Check variable-size...@>= 3633p:=rover; q:=null; clobbered:=false; 3634repeat if (p>=lo_mem_max)or(p<mem_min) then clobbered:=true 3635 else if (rlink(p)>=lo_mem_max)or(rlink(p)<mem_min) then clobbered:=true 3636 else if not(is_empty(p))or(node_size(p)<2)or@| 3637 (p+node_size(p)>lo_mem_max)or@| (llink(rlink(p))<>p) then clobbered:=true; 3638 if clobbered then 3639 begin print_nl("Double-AVAIL list clobbered at "); 3640@.Double-AVAIL list clobbered...@> 3641 print_int(q); goto done2; 3642 end; 3643for q:=p to p+node_size(p)-1 do {mark all locations free} 3644 begin if free[q] then 3645 begin print_nl("Doubly free location at "); 3646@.Doubly free location...@> 3647 print_int(q); goto done2; 3648 end; 3649 free[q]:=true; 3650 end; 3651q:=p; p:=rlink(p); 3652until p=rover; 3653done2: 3654 3655@ @<Check flags...@>= 3656p:=mem_min; 3657while p<=lo_mem_max do {node |p| should not be empty} 3658 begin if is_empty(p) then 3659 begin print_nl("Bad flag at "); print_int(p); 3660@.Bad flag...@> 3661 end; 3662 while (p<=lo_mem_max) and not free[p] do incr(p); 3663 while (p<=lo_mem_max) and free[p] do incr(p); 3664 end 3665 3666@ @<Print newly busy...@>= 3667begin print_nl("New busy locs:"); 3668@.New busy locs@> 3669for p:=mem_min to lo_mem_max do 3670 if not free[p] and ((p>was_lo_max) or was_free[p]) then 3671 begin print_char(" "); print_int(p); 3672 end; 3673for p:=hi_mem_min to mem_end do 3674 if not free[p] and 3675 ((p<was_hi_min) or (p>was_mem_end) or was_free[p]) then 3676 begin print_char(" "); print_int(p); 3677 end; 3678end 3679 3680@ The |search_mem| procedure attempts to answer the question ``Who points 3681to node~|p|?'' In doing so, it fetches |link| and |info| fields of |mem| 3682that might not be of type |two_halves|. Strictly speaking, this is 3683@^dirty \PASCAL@> 3684undefined in \PASCAL, and it can lead to ``false drops'' (words that seem to 3685point to |p| purely by coincidence). But for debugging purposes, we want 3686to rule out the places that do {\sl not\/} point to |p|, so a few false 3687drops are tolerable. 3688 3689@p @!debug procedure search_mem(@!p:pointer); {look for pointers to |p|} 3690var @!q:integer; {current position being searched} 3691begin for q:=mem_min to lo_mem_max do 3692 begin if link(q)=p then 3693 begin print_nl("LINK("); print_int(q); print_char(")"); 3694 end; 3695 if info(q)=p then 3696 begin print_nl("INFO("); print_int(q); print_char(")"); 3697 end; 3698 end; 3699for q:=hi_mem_min to mem_end do 3700 begin if link(q)=p then 3701 begin print_nl("LINK("); print_int(q); print_char(")"); 3702 end; 3703 if info(q)=p then 3704 begin print_nl("INFO("); print_int(q); print_char(")"); 3705 end; 3706 end; 3707@<Search |eqtb| for equivalents equal to |p|@>; 3708end; 3709gubed 3710 3711@* \[12] The command codes. 3712Before we can go much further, we need to define symbolic names for the internal 3713code numbers that represent the various commands obeyed by \MF. These codes 3714are somewhat arbitrary, but not completely so. For example, 3715some codes have been made adjacent so that |case| statements in the 3716program need not consider cases that are widely spaced, or so that |case| 3717statements can be replaced by |if| statements. A command can begin an 3718expression if and only if its code lies between |min_primary_command| and 3719|max_primary_command|, inclusive. The first token of a statement that doesn't 3720begin with an expression has a command code between |min_command| and 3721|max_statement_command|, inclusive. The ordering of the highest-numbered 3722commands (|comma<semicolon<end_group<stop|) is crucial for the parsing 3723and error-recovery methods of this program. 3724 3725At any rate, here is the list, for future reference. 3726 3727@d if_test=1 {conditional text (\&{if})} 3728@d fi_or_else=2 {delimiters for conditionals (\&{elseif}, \&{else}, \&{fi})} 3729@d input=3 {input a source file (\&{input}, \&{endinput})} 3730@d iteration=4 {iterate (\&{for}, \&{forsuffixes}, \&{forever}, \&{endfor})} 3731@d repeat_loop=5 {special command substituted for \&{endfor}} 3732@d exit_test=6 {premature exit from a loop (\&{exitif})} 3733@d relax=7 {do nothing (\.{\char`\\})} 3734@d scan_tokens=8 {put a string into the input buffer} 3735@d expand_after=9 {look ahead one token} 3736@d defined_macro=10 {a macro defined by the user} 3737@d min_command=defined_macro+1 3738@d display_command=11 {online graphic output (\&{display})} 3739@d save_command=12 {save a list of tokens (\&{save})} 3740@d interim_command=13 {save an internal quantity (\&{interim})} 3741@d let_command=14 {redefine a symbolic token (\&{let})} 3742@d new_internal=15 {define a new internal quantity (\&{newinternal})} 3743@d macro_def=16 {define a macro (\&{def}, \&{vardef}, etc.)} 3744@d ship_out_command=17 {output a character (\&{shipout})} 3745@d add_to_command=18 {add to edges (\&{addto})} 3746@d cull_command=19 {cull and normalize edges (\&{cull})} 3747@d tfm_command=20 {command for font metric info (\&{ligtable}, etc.)} 3748@d protection_command=21 {set protection flag (\&{outer}, \&{inner})} 3749@d show_command=22 {diagnostic output (\&{show}, \&{showvariable}, etc.)} 3750@d mode_command=23 {set interaction level (\&{batchmode}, etc.)} 3751@d random_seed=24 {initialize random number generator (\&{randomseed})} 3752@d message_command=25 {communicate to user (\&{message}, \&{errmessage})} 3753@d every_job_command=26 {designate a starting token (\&{everyjob})} 3754@d delimiters=27 {define a pair of delimiters (\&{delimiters})} 3755@d open_window=28 {define a window on the screen (\&{openwindow})} 3756@d special_command=29 {output special info (\&{special}, \&{numspecial})} 3757@d type_name=30 {declare a type (\&{numeric}, \&{pair}, etc.)} 3758@d max_statement_command=type_name 3759@d min_primary_command=type_name 3760@d left_delimiter=31 {the left delimiter of a matching pair} 3761@d begin_group=32 {beginning of a group (\&{begingroup})} 3762@d nullary=33 {an operator without arguments (e.g., \&{normaldeviate})} 3763@d unary=34 {an operator with one argument (e.g., \&{sqrt})} 3764@d str_op=35 {convert a suffix to a string (\&{str})} 3765@d cycle=36 {close a cyclic path (\&{cycle})} 3766@d primary_binary=37 {binary operation taking `\&{of}' (e.g., \&{point})} 3767@d capsule_token=38 {a value that has been put into a token list} 3768@d string_token=39 {a string constant (e.g., |"hello"|)} 3769@d internal_quantity=40 {internal numeric parameter (e.g., \&{pausing})} 3770@d min_suffix_token=internal_quantity 3771@d tag_token=41 {a symbolic token without a primitive meaning} 3772@d numeric_token=42 {a numeric constant (e.g., \.{3.14159})} 3773@d max_suffix_token=numeric_token 3774@d plus_or_minus=43 {either `\.+' or `\.-'} 3775@d max_primary_command=plus_or_minus {should also be |numeric_token+1|} 3776@d min_tertiary_command=plus_or_minus 3777@d tertiary_secondary_macro=44 {a macro defined by \&{secondarydef}} 3778@d tertiary_binary=45 {an operator at the tertiary level (e.g., `\.{++}')} 3779@d max_tertiary_command=tertiary_binary 3780@d left_brace=46 {the operator `\.{\char`\{}'} 3781@d min_expression_command=left_brace 3782@d path_join=47 {the operator `\.{..}'} 3783@d ampersand=48 {the operator `\.\&'} 3784@d expression_tertiary_macro=49 {a macro defined by \&{tertiarydef}} 3785@d expression_binary=50 {an operator at the expression level (e.g., `\.<')} 3786@d equals=51 {the operator `\.='} 3787@d max_expression_command=equals 3788@d and_command=52 {the operator `\&{and}'} 3789@d min_secondary_command=and_command 3790@d secondary_primary_macro=53 {a macro defined by \&{primarydef}} 3791@d slash=54 {the operator `\./'} 3792@d secondary_binary=55 {an operator at the binary level (e.g., \&{shifted})} 3793@d max_secondary_command=secondary_binary 3794@d param_type=56 {type of parameter (\&{primary}, \&{expr}, \&{suffix}, etc.)} 3795@d controls=57 {specify control points explicitly (\&{controls})} 3796@d tension=58 {specify tension between knots (\&{tension})} 3797@d at_least=59 {bounded tension value (\&{atleast})} 3798@d curl_command=60 {specify curl at an end knot (\&{curl})} 3799@d macro_special=61 {special macro operators (\&{quote}, \.{\#\AT!}, etc.)} 3800@d right_delimiter=62 {the right delimiter of a matching pair} 3801@d left_bracket=63 {the operator `\.['} 3802@d right_bracket=64 {the operator `\.]'} 3803@d right_brace=65 {the operator `\.{\char`\}}'} 3804@d with_option=66 {option for filling (\&{withpen}, \&{withweight})} 3805@d cull_op=67 {the operator `\&{keeping}' or `\&{dropping}'} 3806@d thing_to_add=68 3807 {variant of \&{addto} (\&{contour}, \&{doublepath}, \&{also})} 3808@d of_token=69 {the operator `\&{of}'} 3809@d from_token=70 {the operator `\&{from}'} 3810@d to_token=71 {the operator `\&{to}'} 3811@d at_token=72 {the operator `\&{at}'} 3812@d in_window=73 {the operator `\&{inwindow}'} 3813@d step_token=74 {the operator `\&{step}'} 3814@d until_token=75 {the operator `\&{until}'} 3815@d lig_kern_token=76 3816 {the operators `\&{kern}' and `\.{=:}' and `\.{=:\char'174}', etc.} 3817@d assignment=77 {the operator `\.{:=}'} 3818@d skip_to=78 {the operation `\&{skipto}'} 3819@d bchar_label=79 {the operator `\.{\char'174\char'174:}'} 3820@d double_colon=80 {the operator `\.{::}'} 3821@d colon=81 {the operator `\.:'} 3822@# 3823@d comma=82 {the operator `\.,', must be |colon+1|} 3824@d end_of_statement==cur_cmd>comma 3825@d semicolon=83 {the operator `\.;', must be |comma+1|} 3826@d end_group=84 {end a group (\&{endgroup}), must be |semicolon+1|} 3827@d stop=85 {end a job (\&{end}, \&{dump}), must be |end_group+1|} 3828@d max_command_code=stop 3829@d outer_tag=max_command_code+1 {protection code added to command code} 3830 3831@<Types...@>= 3832@!command_code=1..max_command_code; 3833 3834@ Variables and capsules in \MF\ have a variety of ``types,'' 3835distinguished by the following code numbers: 3836 3837@d undefined=0 {no type has been declared} 3838@d unknown_tag=1 {this constant is added to certain type codes below} 3839@d vacuous=1 {no expression was present} 3840@d boolean_type=2 {\&{boolean} with a known value} 3841@d unknown_boolean=boolean_type+unknown_tag 3842@d string_type=4 {\&{string} with a known value} 3843@d unknown_string=string_type+unknown_tag 3844@d pen_type=6 {\&{pen} with a known value} 3845@d unknown_pen=pen_type+unknown_tag 3846@d future_pen=8 {subexpression that will become a \&{pen} at a higher level} 3847@d path_type=9 {\&{path} with a known value} 3848@d unknown_path=path_type+unknown_tag 3849@d picture_type=11 {\&{picture} with a known value} 3850@d unknown_picture=picture_type+unknown_tag 3851@d transform_type=13 {\&{transform} variable or capsule} 3852@d pair_type=14 {\&{pair} variable or capsule} 3853@d numeric_type=15 {variable that has been declared \&{numeric} but not used} 3854@d known=16 {\&{numeric} with a known value} 3855@d dependent=17 {a linear combination with |fraction| coefficients} 3856@d proto_dependent=18 {a linear combination with |scaled| coefficients} 3857@d independent=19 {\&{numeric} with unknown value} 3858@d token_list=20 {variable name or suffix argument or text argument} 3859@d structured=21 {variable with subscripts and attributes} 3860@d unsuffixed_macro=22 {variable defined with \&{vardef} but no \.{\AT!\#}} 3861@d suffixed_macro=23 {variable defined with \&{vardef} and \.{\AT!\#}} 3862@# 3863@d unknown_types==unknown_boolean,unknown_string, 3864 unknown_pen,unknown_picture,unknown_path 3865 3866@<Basic printing procedures@>= 3867procedure print_type(@!t:small_number); 3868begin case t of 3869vacuous:print("vacuous"); 3870boolean_type:print("boolean"); 3871unknown_boolean:print("unknown boolean"); 3872string_type:print("string"); 3873unknown_string:print("unknown string"); 3874pen_type:print("pen"); 3875unknown_pen:print("unknown pen"); 3876future_pen:print("future pen"); 3877path_type:print("path"); 3878unknown_path:print("unknown path"); 3879picture_type:print("picture"); 3880unknown_picture:print("unknown picture"); 3881transform_type:print("transform"); 3882pair_type:print("pair"); 3883known:print("known numeric"); 3884dependent:print("dependent"); 3885proto_dependent:print("proto-dependent"); 3886numeric_type:print("numeric"); 3887independent:print("independent"); 3888token_list:print("token list"); 3889structured:print("structured"); 3890unsuffixed_macro:print("unsuffixed macro"); 3891suffixed_macro:print("suffixed macro"); 3892othercases print("undefined") 3893endcases; 3894end; 3895 3896@ Values inside \MF\ are stored in two-word nodes that have a |name_type| 3897as well as a |type|. The possibilities for |name_type| are defined 3898here; they will be explained in more detail later. 3899 3900@d root=0 {|name_type| at the top level of a variable} 3901@d saved_root=1 {same, when the variable has been saved} 3902@d structured_root=2 {|name_type| where a |structured| branch occurs} 3903@d subscr=3 {|name_type| in a subscript node} 3904@d attr=4 {|name_type| in an attribute node} 3905@d x_part_sector=5 {|name_type| in the \&{xpart} of a node} 3906@d y_part_sector=6 {|name_type| in the \&{ypart} of a node} 3907@d xx_part_sector=7 {|name_type| in the \&{xxpart} of a node} 3908@d xy_part_sector=8 {|name_type| in the \&{xypart} of a node} 3909@d yx_part_sector=9 {|name_type| in the \&{yxpart} of a node} 3910@d yy_part_sector=10 {|name_type| in the \&{yypart} of a node} 3911@d capsule=11 {|name_type| in stashed-away subexpressions} 3912@d token=12 {|name_type| in a numeric token or string token} 3913 3914@ Primitive operations that produce values have a secondary identification 3915code in addition to their command code; it's something like genera and species. 3916For example, `\.*' has the command code |primary_binary|, and its 3917secondary identification is |times|. The secondary codes start at 30 so that 3918they don't overlap with the type codes; some type codes (e.g., |string_type|) 3919are used as operators as well as type identifications. 3920 3921@d true_code=30 {operation code for \.{true}} 3922@d false_code=31 {operation code for \.{false}} 3923@d null_picture_code=32 {operation code for \.{nullpicture}} 3924@d null_pen_code=33 {operation code for \.{nullpen}} 3925@d job_name_op=34 {operation code for \.{jobname}} 3926@d read_string_op=35 {operation code for \.{readstring}} 3927@d pen_circle=36 {operation code for \.{pencircle}} 3928@d normal_deviate=37 {operation code for \.{normaldeviate}} 3929@d odd_op=38 {operation code for \.{odd}} 3930@d known_op=39 {operation code for \.{known}} 3931@d unknown_op=40 {operation code for \.{unknown}} 3932@d not_op=41 {operation code for \.{not}} 3933@d decimal=42 {operation code for \.{decimal}} 3934@d reverse=43 {operation code for \.{reverse}} 3935@d make_path_op=44 {operation code for \.{makepath}} 3936@d make_pen_op=45 {operation code for \.{makepen}} 3937@d total_weight_op=46 {operation code for \.{totalweight}} 3938@d oct_op=47 {operation code for \.{oct}} 3939@d hex_op=48 {operation code for \.{hex}} 3940@d ASCII_op=49 {operation code for \.{ASCII}} 3941@d char_op=50 {operation code for \.{char}} 3942@d length_op=51 {operation code for \.{length}} 3943@d turning_op=52 {operation code for \.{turningnumber}} 3944@d x_part=53 {operation code for \.{xpart}} 3945@d y_part=54 {operation code for \.{ypart}} 3946@d xx_part=55 {operation code for \.{xxpart}} 3947@d xy_part=56 {operation code for \.{xypart}} 3948@d yx_part=57 {operation code for \.{yxpart}} 3949@d yy_part=58 {operation code for \.{yypart}} 3950@d sqrt_op=59 {operation code for \.{sqrt}} 3951@d m_exp_op=60 {operation code for \.{mexp}} 3952@d m_log_op=61 {operation code for \.{mlog}} 3953@d sin_d_op=62 {operation code for \.{sind}} 3954@d cos_d_op=63 {operation code for \.{cosd}} 3955@d floor_op=64 {operation code for \.{floor}} 3956@d uniform_deviate=65 {operation code for \.{uniformdeviate}} 3957@d char_exists_op=66 {operation code for \.{charexists}} 3958@d angle_op=67 {operation code for \.{angle}} 3959@d cycle_op=68 {operation code for \.{cycle}} 3960@d plus=69 {operation code for \.+} 3961@d minus=70 {operation code for \.-} 3962@d times=71 {operation code for \.*} 3963@d over=72 {operation code for \./} 3964@d pythag_add=73 {operation code for \.{++}} 3965@d pythag_sub=74 {operation code for \.{+-+}} 3966@d or_op=75 {operation code for \.{or}} 3967@d and_op=76 {operation code for \.{and}} 3968@d less_than=77 {operation code for \.<} 3969@d less_or_equal=78 {operation code for \.{<=}} 3970@d greater_than=79 {operation code for \.>} 3971@d greater_or_equal=80 {operation code for \.{>=}} 3972@d equal_to=81 {operation code for \.=} 3973@d unequal_to=82 {operation code for \.{<>}} 3974@d concatenate=83 {operation code for \.\&} 3975@d rotated_by=84 {operation code for \.{rotated}} 3976@d slanted_by=85 {operation code for \.{slanted}} 3977@d scaled_by=86 {operation code for \.{scaled}} 3978@d shifted_by=87 {operation code for \.{shifted}} 3979@d transformed_by=88 {operation code for \.{transformed}} 3980@d x_scaled=89 {operation code for \.{xscaled}} 3981@d y_scaled=90 {operation code for \.{yscaled}} 3982@d z_scaled=91 {operation code for \.{zscaled}} 3983@d intersect=92 {operation code for \.{intersectiontimes}} 3984@d double_dot=93 {operation code for improper \.{..}} 3985@d substring_of=94 {operation code for \.{substring}} 3986@d min_of=substring_of 3987@d subpath_of=95 {operation code for \.{subpath}} 3988@d direction_time_of=96 {operation code for \.{directiontime}} 3989@d point_of=97 {operation code for \.{point}} 3990@d precontrol_of=98 {operation code for \.{precontrol}} 3991@d postcontrol_of=99 {operation code for \.{postcontrol}} 3992@d pen_offset_of=100 {operation code for \.{penoffset}} 3993 3994@p procedure print_op(@!c:quarterword); 3995begin if c<=numeric_type then print_type(c) 3996else case c of 3997true_code:print("true"); 3998false_code:print("false"); 3999null_picture_code:print("nullpicture"); 4000null_pen_code:print("nullpen"); 4001job_name_op:print("jobname"); 4002read_string_op:print("readstring"); 4003pen_circle:print("pencircle"); 4004normal_deviate:print("normaldeviate"); 4005odd_op:print("odd"); 4006known_op:print("known"); 4007unknown_op:print("unknown"); 4008not_op:print("not"); 4009decimal:print("decimal"); 4010reverse:print("reverse"); 4011make_path_op:print("makepath"); 4012make_pen_op:print("makepen"); 4013total_weight_op:print("totalweight"); 4014oct_op:print("oct"); 4015hex_op:print("hex"); 4016ASCII_op:print("ASCII"); 4017char_op:print("char"); 4018length_op:print("length"); 4019turning_op:print("turningnumber"); 4020x_part:print("xpart"); 4021y_part:print("ypart"); 4022xx_part:print("xxpart"); 4023xy_part:print("xypart"); 4024yx_part:print("yxpart"); 4025yy_part:print("yypart"); 4026sqrt_op:print("sqrt"); 4027m_exp_op:print("mexp"); 4028m_log_op:print("mlog"); 4029sin_d_op:print("sind"); 4030cos_d_op:print("cosd"); 4031floor_op:print("floor"); 4032uniform_deviate:print("uniformdeviate"); 4033char_exists_op:print("charexists"); 4034angle_op:print("angle"); 4035cycle_op:print("cycle"); 4036plus:print_char("+"); 4037minus:print_char("-"); 4038times:print_char("*"); 4039over:print_char("/"); 4040pythag_add:print("++"); 4041pythag_sub:print("+-+"); 4042or_op:print("or"); 4043and_op:print("and"); 4044less_than:print_char("<"); 4045less_or_equal:print("<="); 4046greater_than:print_char(">"); 4047greater_or_equal:print(">="); 4048equal_to:print_char("="); 4049unequal_to:print("<>"); 4050concatenate:print("&"); 4051rotated_by:print("rotated"); 4052slanted_by:print("slanted"); 4053scaled_by:print("scaled"); 4054shifted_by:print("shifted"); 4055transformed_by:print("transformed"); 4056x_scaled:print("xscaled"); 4057y_scaled:print("yscaled"); 4058z_scaled:print("zscaled"); 4059intersect:print("intersectiontimes"); 4060substring_of:print("substring"); 4061subpath_of:print("subpath"); 4062direction_time_of:print("directiontime"); 4063point_of:print("point"); 4064precontrol_of:print("precontrol"); 4065postcontrol_of:print("postcontrol"); 4066pen_offset_of:print("penoffset"); 4067othercases print("..") 4068endcases; 4069end; 4070 4071@ \MF\ also has a bunch of internal parameters that a user might want to 4072fuss with. Every such parameter has an identifying code number, defined here. 4073 4074@d tracing_titles=1 {show titles online when they appear} 4075@d tracing_equations=2 {show each variable when it becomes known} 4076@d tracing_capsules=3 {show capsules too} 4077@d tracing_choices=4 {show the control points chosen for paths} 4078@d tracing_specs=5 {show subdivision of paths into octants before digitizing} 4079@d tracing_pens=6 {show details of pens that are made} 4080@d tracing_commands=7 {show commands and operations before they are performed} 4081@d tracing_restores=8 {show when a variable or internal is restored} 4082@d tracing_macros=9 {show macros before they are expanded} 4083@d tracing_edges=10 {show digitized edges as they are computed} 4084@d tracing_output=11 {show digitized edges as they are output} 4085@d tracing_stats=12 {show memory usage at end of job} 4086@d tracing_online=13 {show long diagnostics on terminal and in the log file} 4087@d year=14 {the current year (e.g., 1984)} 4088@d month=15 {the current month (e.g., 3 $\equiv$ March)} 4089@d day=16 {the current day of the month} 4090@d time=17 {the number of minutes past midnight when this job started} 4091@d char_code=18 {the number of the next character to be output} 4092@d char_ext=19 {the extension code of the next character to be output} 4093@d char_wd=20 {the width of the next character to be output} 4094@d char_ht=21 {the height of the next character to be output} 4095@d char_dp=22 {the depth of the next character to be output} 4096@d char_ic=23 {the italic correction of the next character to be output} 4097@d char_dx=24 {the device's $x$ movement for the next character, in pixels} 4098@d char_dy=25 {the device's $y$ movement for the next character, in pixels} 4099@d design_size=26 {the unit of measure used for |char_wd..char_ic|, in points} 4100@d hppp=27 {the number of horizontal pixels per point} 4101@d vppp=28 {the number of vertical pixels per point} 4102@d x_offset=29 {horizontal displacement of shipped-out characters} 4103@d y_offset=30 {vertical displacement of shipped-out characters} 4104@d pausing=31 {positive to display lines on the terminal before they are read} 4105@d showstopping=32 {positive to stop after each \&{show} command} 4106@d fontmaking=33 {positive if font metric output is to be produced} 4107@d proofing=34 {positive for proof mode, negative to suppress output} 4108@d smoothing=35 {positive if moves are to be ``smoothed''} 4109@d autorounding=36 {controls path modification to ``good'' points} 4110@d granularity=37 {autorounding uses this pixel size} 4111@d fillin=38 {extra darkness of diagonal lines} 4112@d turning_check=39 {controls reorientation of clockwise paths} 4113@d warning_check=40 {controls error message when variable value is large} 4114@d boundary_char=41 {the right boundary character for ligatures} 4115@d max_given_internal=41 4116 4117@<Glob...@>= 4118@!internal:array[1..max_internal] of scaled; 4119 {the values of internal quantities} 4120@!int_name:array[1..max_internal] of str_number; 4121 {their names} 4122@!int_ptr:max_given_internal..max_internal; 4123 {the maximum internal quantity defined so far} 4124 4125@ @<Set init...@>= 4126for k:=1 to max_given_internal do internal[k]:=0; 4127int_ptr:=max_given_internal; 4128 4129@ The symbolic names for internal quantities are put into \MF's hash table 4130by using a routine called |primitive|, which will be defined later. Let us 4131enter them now, so that we don't have to list all those names again 4132anywhere else. 4133 4134@<Put each of \MF's primitives into the hash table@>= 4135primitive("tracingtitles",internal_quantity,tracing_titles);@/ 4136@!@:tracingtitles_}{\&{tracingtitles} primitive@> 4137primitive("tracingequations",internal_quantity,tracing_equations);@/ 4138@!@:tracing_equations_}{\&{tracingequations} primitive@> 4139primitive("tracingcapsules",internal_quantity,tracing_capsules);@/ 4140@!@:tracing_capsules_}{\&{tracingcapsules} primitive@> 4141primitive("tracingchoices",internal_quantity,tracing_choices);@/ 4142@!@:tracing_choices_}{\&{tracingchoices} primitive@> 4143primitive("tracingspecs",internal_quantity,tracing_specs);@/ 4144@!@:tracing_specs_}{\&{tracingspecs} primitive@> 4145primitive("tracingpens",internal_quantity,tracing_pens);@/ 4146@!@:tracing_pens_}{\&{tracingpens} primitive@> 4147primitive("tracingcommands",internal_quantity,tracing_commands);@/ 4148@!@:tracing_commands_}{\&{tracingcommands} primitive@> 4149primitive("tracingrestores",internal_quantity,tracing_restores);@/ 4150@!@:tracing_restores_}{\&{tracingrestores} primitive@> 4151primitive("tracingmacros",internal_quantity,tracing_macros);@/ 4152@!@:tracing_macros_}{\&{tracingmacros} primitive@> 4153primitive("tracingedges",internal_quantity,tracing_edges);@/ 4154@!@:tracing_edges_}{\&{tracingedges} primitive@> 4155primitive("tracingoutput",internal_quantity,tracing_output);@/ 4156@!@:tracing_output_}{\&{tracingoutput} primitive@> 4157primitive("tracingstats",internal_quantity,tracing_stats);@/ 4158@!@:tracing_stats_}{\&{tracingstats} primitive@> 4159primitive("tracingonline",internal_quantity,tracing_online);@/ 4160@!@:tracing_online_}{\&{tracingonline} primitive@> 4161primitive("year",internal_quantity,year);@/ 4162@!@:year_}{\&{year} primitive@> 4163primitive("month",internal_quantity,month);@/ 4164@!@:month_}{\&{month} primitive@> 4165primitive("day",internal_quantity,day);@/ 4166@!@:day_}{\&{day} primitive@> 4167primitive("time",internal_quantity,time);@/ 4168@!@:time_}{\&{time} primitive@> 4169primitive("charcode",internal_quantity,char_code);@/ 4170@!@:char_code_}{\&{charcode} primitive@> 4171primitive("charext",internal_quantity,char_ext);@/ 4172@!@:char_ext_}{\&{charext} primitive@> 4173primitive("charwd",internal_quantity,char_wd);@/ 4174@!@:char_wd_}{\&{charwd} primitive@> 4175primitive("charht",internal_quantity,char_ht);@/ 4176@!@:char_ht_}{\&{charht} primitive@> 4177primitive("chardp",internal_quantity,char_dp);@/ 4178@!@:char_dp_}{\&{chardp} primitive@> 4179primitive("charic",internal_quantity,char_ic);@/ 4180@!@:char_ic_}{\&{charic} primitive@> 4181primitive("chardx",internal_quantity,char_dx);@/ 4182@!@:char_dx_}{\&{chardx} primitive@> 4183primitive("chardy",internal_quantity,char_dy);@/ 4184@!@:char_dy_}{\&{chardy} primitive@> 4185primitive("designsize",internal_quantity,design_size);@/ 4186@!@:design_size_}{\&{designsize} primitive@> 4187primitive("hppp",internal_quantity,hppp);@/ 4188@!@:hppp_}{\&{hppp} primitive@> 4189primitive("vppp",internal_quantity,vppp);@/ 4190@!@:vppp_}{\&{vppp} primitive@> 4191primitive("xoffset",internal_quantity,x_offset);@/ 4192@!@:x_offset_}{\&{xoffset} primitive@> 4193primitive("yoffset",internal_quantity,y_offset);@/ 4194@!@:y_offset_}{\&{yoffset} primitive@> 4195primitive("pausing",internal_quantity,pausing);@/ 4196@!@:pausing_}{\&{pausing} primitive@> 4197primitive("showstopping",internal_quantity,showstopping);@/ 4198@!@:showstopping_}{\&{showstopping} primitive@> 4199primitive("fontmaking",internal_quantity,fontmaking);@/ 4200@!@:fontmaking_}{\&{fontmaking} primitive@> 4201primitive("proofing",internal_quantity,proofing);@/ 4202@!@:proofing_}{\&{proofing} primitive@> 4203primitive("smoothing",internal_quantity,smoothing);@/ 4204@!@:smoothing_}{\&{smoothing} primitive@> 4205primitive("autorounding",internal_quantity,autorounding);@/ 4206@!@:autorounding_}{\&{autorounding} primitive@> 4207primitive("granularity",internal_quantity,granularity);@/ 4208@!@:granularity_}{\&{granularity} primitive@> 4209primitive("fillin",internal_quantity,fillin);@/ 4210@!@:fillin_}{\&{fillin} primitive@> 4211primitive("turningcheck",internal_quantity,turning_check);@/ 4212@!@:turning_check_}{\&{turningcheck} primitive@> 4213primitive("warningcheck",internal_quantity,warning_check);@/ 4214@!@:warning_check_}{\&{warningcheck} primitive@> 4215primitive("boundarychar",internal_quantity,boundary_char);@/ 4216@!@:boundary_char_}{\&{boundarychar} primitive@> 4217 4218@ Well, we do have to list the names one more time, for use in symbolic 4219printouts. 4220 4221@<Initialize table...@>= 4222int_name[tracing_titles]:="tracingtitles"; 4223int_name[tracing_equations]:="tracingequations"; 4224int_name[tracing_capsules]:="tracingcapsules"; 4225int_name[tracing_choices]:="tracingchoices"; 4226int_name[tracing_specs]:="tracingspecs"; 4227int_name[tracing_pens]:="tracingpens"; 4228int_name[tracing_commands]:="tracingcommands"; 4229int_name[tracing_restores]:="tracingrestores"; 4230int_name[tracing_macros]:="tracingmacros"; 4231int_name[tracing_edges]:="tracingedges"; 4232int_name[tracing_output]:="tracingoutput"; 4233int_name[tracing_stats]:="tracingstats"; 4234int_name[tracing_online]:="tracingonline"; 4235int_name[year]:="year"; 4236int_name[month]:="month"; 4237int_name[day]:="day"; 4238int_name[time]:="time"; 4239int_name[char_code]:="charcode"; 4240int_name[char_ext]:="charext"; 4241int_name[char_wd]:="charwd"; 4242int_name[char_ht]:="charht"; 4243int_name[char_dp]:="chardp"; 4244int_name[char_ic]:="charic"; 4245int_name[char_dx]:="chardx"; 4246int_name[char_dy]:="chardy"; 4247int_name[design_size]:="designsize"; 4248int_name[hppp]:="hppp"; 4249int_name[vppp]:="vppp"; 4250int_name[x_offset]:="xoffset"; 4251int_name[y_offset]:="yoffset"; 4252int_name[pausing]:="pausing"; 4253int_name[showstopping]:="showstopping"; 4254int_name[fontmaking]:="fontmaking"; 4255int_name[proofing]:="proofing"; 4256int_name[smoothing]:="smoothing"; 4257int_name[autorounding]:="autorounding"; 4258int_name[granularity]:="granularity"; 4259int_name[fillin]:="fillin"; 4260int_name[turning_check]:="turningcheck"; 4261int_name[warning_check]:="warningcheck"; 4262int_name[boundary_char]:="boundarychar"; 4263 4264@ The following procedure, which is called just before \MF\ initializes its 4265input and output, establishes the initial values of the date and time. 4266@^system dependencies@> 4267Since standard \PASCAL\ cannot provide such information, something special 4268is needed. The program here simply specifies July 4, 1776, at noon; but 4269users probably want a better approximation to the truth. 4270 4271Note that the values are |scaled| integers. Hence \MF\ can no longer 4272be used after the year 32767. 4273 4274@p procedure fix_date_and_time; 4275begin internal[time]:=12*60*unity; {minutes since midnight} 4276internal[day]:=4*unity; {fourth day of the month} 4277internal[month]:=7*unity; {seventh month of the year} 4278internal[year]:=1776*unity; {Anno Domini} 4279end; 4280 4281@ \MF\ is occasionally supposed to print diagnostic information that 4282goes only into the transcript file, unless |tracing_online| is positive. 4283Now that we have defined |tracing_online| we can define 4284two routines that adjust the destination of print commands: 4285 4286@<Basic printing...@>= 4287procedure begin_diagnostic; {prepare to do some tracing} 4288begin old_setting:=selector; 4289if(internal[tracing_online]<=0)and(selector=term_and_log) then 4290 begin decr(selector); 4291 if history=spotless then history:=warning_issued; 4292 end; 4293end; 4294@# 4295procedure end_diagnostic(@!blank_line:boolean); 4296 {restore proper conditions after tracing} 4297begin print_nl(""); 4298if blank_line then print_ln; 4299selector:=old_setting; 4300end; 4301 4302@ Of course we had better declare another global variable, if the previous 4303routines are going to work. 4304 4305@<Glob...@>= 4306@!old_setting:0..max_selector; 4307 4308@ We will occasionally use |begin_diagnostic| in connection with line-number 4309printing, as follows. (The parameter |s| is typically |"Path"| or 4310|"Cycle spec"|, etc.) 4311 4312@<Basic printing...@>= 4313procedure print_diagnostic(@!s,@!t:str_number;@!nuline:boolean); 4314begin begin_diagnostic; 4315if nuline then print_nl(s)@+else print(s); 4316print(" at line "); print_int(line); 4317print(t); print_char(":"); 4318end; 4319 4320@ The 256 |ASCII_code| characters are grouped into classes by means of 4321the |char_class| table. Individual class numbers have no semantic 4322or syntactic significance, except in a few instances defined here. 4323There's also |max_class|, which can be used as a basis for additional 4324class numbers in nonstandard extensions of \MF. 4325 4326@d digit_class=0 {the class number of \.{0123456789}} 4327@d period_class=1 {the class number of `\..'} 4328@d space_class=2 {the class number of spaces and nonstandard characters} 4329@d percent_class=3 {the class number of `\.\%'} 4330@d string_class=4 {the class number of `\."'} 4331@d right_paren_class=8 {the class number of `\.)'} 4332@d isolated_classes==5,6,7,8 {characters that make length-one tokens only} 4333@d letter_class=9 {letters and the underline character} 4334@d left_bracket_class=17 {`\.['} 4335@d right_bracket_class=18 {`\.]'} 4336@d invalid_class=20 {bad character in the input} 4337@d max_class=20 {the largest class number} 4338 4339@<Glob...@>= 4340@!char_class:array[ASCII_code] of 0..max_class; {the class numbers} 4341 4342@ If changes are made to accommodate non-ASCII character sets, they should 4343follow the guidelines in Appendix~C of {\sl The {\logos METAFONT\/}book}. 4344@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 4345@^system dependencies@> 4346 4347@<Set init...@>= 4348for k:="0" to "9" do char_class[k]:=digit_class; 4349char_class["."]:=period_class; 4350char_class[" "]:=space_class; 4351char_class["%"]:=percent_class; 4352char_class[""""]:=string_class;@/ 4353char_class[","]:=5; 4354char_class[";"]:=6; 4355char_class["("]:=7; 4356char_class[")"]:=right_paren_class; 4357for k:="A" to "Z" do char_class[k]:=letter_class; 4358for k:="a" to "z" do char_class[k]:=letter_class; 4359char_class["_"]:=letter_class;@/ 4360char_class["<"]:=10; 4361char_class["="]:=10; 4362char_class[">"]:=10; 4363char_class[":"]:=10; 4364char_class["|"]:=10;@/ 4365char_class["`"]:=11; 4366char_class["'"]:=11;@/ 4367char_class["+"]:=12; 4368char_class["-"]:=12;@/ 4369char_class["/"]:=13; 4370char_class["*"]:=13; 4371char_class["\"]:=13;@/ 4372char_class["!"]:=14; 4373char_class["?"]:=14;@/ 4374char_class["#"]:=15; 4375char_class["&"]:=15; 4376char_class["@@"]:=15; 4377char_class["$"]:=15;@/ 4378char_class["^"]:=16; 4379char_class["~"]:=16;@/ 4380char_class["["]:=left_bracket_class; 4381char_class["]"]:=right_bracket_class;@/ 4382char_class["{"]:=19; 4383char_class["}"]:=19;@/ 4384for k:=0 to " "-1 do char_class[k]:=invalid_class; 4385for k:=127 to 255 do char_class[k]:=invalid_class; 4386 4387@* \[13] The hash table. 4388Symbolic tokens are stored and retrieved by means of a fairly standard hash 4389table algorithm called the method of ``coalescing lists'' (cf.\ Algorithm 6.4C 4390in {\sl The Art of Computer Programming\/}). Once a symbolic token enters the 4391table, it is never removed. 4392 4393The actual sequence of characters forming a symbolic token is 4394stored in the |str_pool| array together with all the other strings. An 4395auxiliary array |hash| consists of items with two halfword fields per 4396word. The first of these, called |next(p)|, points to the next identifier 4397belonging to the same coalesced list as the identifier corresponding to~|p|; 4398and the other, called |text(p)|, points to the |str_start| entry for 4399|p|'s identifier. If position~|p| of the hash table is empty, we have 4400|text(p)=0|; if position |p| is either empty or the end of a coalesced 4401hash list, we have |next(p)=0|. 4402 4403An auxiliary pointer variable called |hash_used| is maintained in such a 4404way that all locations |p>=hash_used| are nonempty. The global variable 4405|st_count| tells how many symbolic tokens have been defined, if statistics 4406are being kept. 4407 4408The first 256 locations of |hash| are reserved for symbols of length one. 4409 4410There's a parallel array called |eqtb| that contains the current equivalent 4411values of each symbolic token. The entries of this array consist of 4412two halfwords called |eq_type| (a command code) and |equiv| (a secondary 4413piece of information that qualifies the |eq_type|). 4414 4415@d next(#) == hash[#].lh {link for coalesced lists} 4416@d text(#) == hash[#].rh {string number for symbolic token name} 4417@d eq_type(#) == eqtb[#].lh {the current ``meaning'' of a symbolic token} 4418@d equiv(#) == eqtb[#].rh {parametric part of a token's meaning} 4419@d hash_base=257 {hashing actually starts here} 4420@d hash_is_full == (hash_used=hash_base) {are all positions occupied?} 4421 4422@<Glob...@>= 4423@!hash_used:pointer; {allocation pointer for |hash|} 4424@!st_count:integer; {total number of known identifiers} 4425 4426@ Certain entries in the hash table are ``frozen'' and not redefinable, 4427since they are used in error recovery. 4428 4429@d hash_top==hash_base+hash_size {the first location of the frozen area} 4430@d frozen_inaccessible==hash_top {|hash| location to protect the frozen area} 4431@d frozen_repeat_loop==hash_top+1 {|hash| location of a loop-repeat token} 4432@d frozen_right_delimiter==hash_top+2 {|hash| location of a permanent `\.)'} 4433@d frozen_left_bracket==hash_top+3 {|hash| location of a permanent `\.['} 4434@d frozen_slash==hash_top+4 {|hash| location of a permanent `\./'} 4435@d frozen_colon==hash_top+5 {|hash| location of a permanent `\.:'} 4436@d frozen_semicolon==hash_top+6 {|hash| location of a permanent `\.;'} 4437@d frozen_end_for==hash_top+7 {|hash| location of a permanent \&{endfor}} 4438@d frozen_end_def==hash_top+8 {|hash| location of a permanent \&{enddef}} 4439@d frozen_fi==hash_top+9 {|hash| location of a permanent \&{fi}} 4440@d frozen_end_group==hash_top+10 4441 {|hash| location of a permanent `\.{endgroup}'} 4442@d frozen_bad_vardef==hash_top+11 {|hash| location of `\.{a bad variable}'} 4443@d frozen_undefined==hash_top+12 {|hash| location that never gets defined} 4444@d hash_end==hash_top+12 {the actual size of the |hash| and |eqtb| arrays} 4445 4446@<Glob...@>= 4447@!hash: array[1..hash_end] of two_halves; {the hash table} 4448@!eqtb: array[1..hash_end] of two_halves; {the equivalents} 4449 4450@ @<Set init...@>= 4451next(1):=0; text(1):=0; eq_type(1):=tag_token; equiv(1):=null; 4452for k:=2 to hash_end do 4453 begin hash[k]:=hash[1]; eqtb[k]:=eqtb[1]; 4454 end; 4455 4456@ @<Initialize table entries...@>= 4457hash_used:=frozen_inaccessible; {nothing is used} 4458st_count:=0;@/ 4459text(frozen_bad_vardef):="a bad variable"; 4460text(frozen_fi):="fi"; 4461text(frozen_end_group):="endgroup"; 4462text(frozen_end_def):="enddef"; 4463text(frozen_end_for):="endfor";@/ 4464text(frozen_semicolon):=";"; 4465text(frozen_colon):=":"; 4466text(frozen_slash):="/"; 4467text(frozen_left_bracket):="["; 4468text(frozen_right_delimiter):=")";@/ 4469text(frozen_inaccessible):=" INACCESSIBLE";@/ 4470eq_type(frozen_right_delimiter):=right_delimiter; 4471 4472@ @<Check the ``constant'' values...@>= 4473if hash_end+max_internal>max_halfword then bad:=21; 4474 4475@ Here is the subroutine that searches the hash table for an identifier 4476that matches a given string of length~|l| appearing in |buffer[j.. 4477(j+l-1)]|. If the identifier is not found, it is inserted; hence it 4478will always be found, and the corresponding hash table address 4479will be returned. 4480 4481@p function id_lookup(@!j,@!l:integer):pointer; {search the hash table} 4482label found; {go here when you've found it} 4483var @!h:integer; {hash code} 4484@!p:pointer; {index in |hash| array} 4485@!k:pointer; {index in |buffer| array} 4486begin if l=1 then @<Treat special case of length 1 and |goto found|@>; 4487@<Compute the hash code |h|@>; 4488p:=h+hash_base; {we start searching here; note that |0<=h<hash_prime|} 4489loop@+ begin if text(p)>0 then if length(text(p))=l then 4490 if str_eq_buf(text(p),j) then goto found; 4491 if next(p)=0 then 4492 @<Insert a new symbolic token after |p|, then 4493 make |p| point to it and |goto found|@>; 4494 p:=next(p); 4495 end; 4496found: id_lookup:=p; 4497end; 4498 4499@ @<Treat special case of length 1...@>= 4500begin p:=buffer[j]+1; text(p):=p-1; goto found; 4501end 4502 4503@ @<Insert a new symbolic...@>= 4504begin if text(p)>0 then 4505 begin repeat if hash_is_full then 4506 overflow("hash size",hash_size); 4507@:METAFONT capacity exceeded hash size}{\quad hash size@> 4508 decr(hash_used); 4509 until text(hash_used)=0; {search for an empty location in |hash|} 4510 next(p):=hash_used; p:=hash_used; 4511 end; 4512str_room(l); 4513for k:=j to j+l-1 do append_char(buffer[k]); 4514text(p):=make_string; str_ref[text(p)]:=max_str_ref; 4515@!stat incr(st_count);@+tats@;@/ 4516goto found; 4517end 4518 4519@ The value of |hash_prime| should be roughly 85\pct! of |hash_size|, and it 4520should be a prime number. The theory of hashing tells us to expect fewer 4521than two table probes, on the average, when the search is successful. 4522[See J.~S. Vitter, {\sl Journal of the ACM\/ \bf30} (1983), 231--258.] 4523@^Vitter, Jeffrey Scott@> 4524 4525@<Compute the hash code |h|@>= 4526h:=buffer[j]; 4527for k:=j+1 to j+l-1 do 4528 begin h:=h+h+buffer[k]; 4529 while h>=hash_prime do h:=h-hash_prime; 4530 end 4531 4532@ @<Search |eqtb| for equivalents equal to |p|@>= 4533for q:=1 to hash_end do 4534 begin if equiv(q)=p then 4535 begin print_nl("EQUIV("); print_int(q); print_char(")"); 4536 end; 4537 end 4538 4539@ We need to put \MF's ``primitive'' symbolic tokens into the hash 4540table, together with their command code (which will be the |eq_type|) 4541and an operand (which will be the |equiv|). The |primitive| procedure 4542does this, in a way that no \MF\ user can. The global value |cur_sym| 4543contains the new |eqtb| pointer after |primitive| has acted. 4544 4545@p @!init procedure primitive(@!s:str_number;@!c:halfword;@!o:halfword); 4546var @!k:pool_pointer; {index into |str_pool|} 4547@!j:small_number; {index into |buffer|} 4548@!l:small_number; {length of the string} 4549begin k:=str_start[s]; l:=str_start[s+1]-k; 4550 {we will move |s| into the (empty) |buffer|} 4551for j:=0 to l-1 do buffer[j]:=so(str_pool[k+j]); 4552cur_sym:=id_lookup(0,l);@/ 4553if s>=256 then {we don't want to have the string twice} 4554 begin flush_string(str_ptr-1); text(cur_sym):=s; 4555 end; 4556eq_type(cur_sym):=c; equiv(cur_sym):=o; 4557end; 4558tini 4559 4560@ Many of \MF's primitives need no |equiv|, since they are identifiable 4561by their |eq_type| alone. These primitives are loaded into the hash table 4562as follows: 4563 4564@<Put each of \MF's primitives into the hash table@>= 4565primitive("..",path_join,0);@/ 4566@!@:.._}{\.{..} primitive@> 4567primitive("[",left_bracket,0); eqtb[frozen_left_bracket]:=eqtb[cur_sym];@/ 4568@!@:[ }{\.{[} primitive@> 4569primitive("]",right_bracket,0);@/ 4570@!@:] }{\.{]} primitive@> 4571primitive("}",right_brace,0);@/ 4572@!@:]]}{\.{\char`\}} primitive@> 4573primitive("{",left_brace,0);@/ 4574@!@:][}{\.{\char`\{} primitive@> 4575primitive(":",colon,0); eqtb[frozen_colon]:=eqtb[cur_sym];@/ 4576@!@:: }{\.{:} primitive@> 4577primitive("::",double_colon,0);@/ 4578@!@::: }{\.{::} primitive@> 4579primitive("||:",bchar_label,0);@/ 4580@!@:::: }{\.{\char'174\char'174:} primitive@> 4581primitive(":=",assignment,0);@/ 4582@!@::=_}{\.{:=} primitive@> 4583primitive(",",comma,0);@/ 4584@!@:, }{\., primitive@> 4585primitive(";",semicolon,0); eqtb[frozen_semicolon]:=eqtb[cur_sym];@/ 4586@!@:; }{\.; primitive@> 4587primitive("\",relax,0);@/ 4588@!@:]]\\}{\.{\char`\\} primitive@> 4589@# 4590primitive("addto",add_to_command,0);@/ 4591@!@:add_to_}{\&{addto} primitive@> 4592primitive("at",at_token,0);@/ 4593@!@:at_}{\&{at} primitive@> 4594primitive("atleast",at_least,0);@/ 4595@!@:at_least_}{\&{atleast} primitive@> 4596primitive("begingroup",begin_group,0); bg_loc:=cur_sym;@/ 4597@!@:begin_group_}{\&{begingroup} primitive@> 4598primitive("controls",controls,0);@/ 4599@!@:controls_}{\&{controls} primitive@> 4600primitive("cull",cull_command,0);@/ 4601@!@:cull_}{\&{cull} primitive@> 4602primitive("curl",curl_command,0);@/ 4603@!@:curl_}{\&{curl} primitive@> 4604primitive("delimiters",delimiters,0);@/ 4605@!@:delimiters_}{\&{delimiters} primitive@> 4606primitive("display",display_command,0);@/ 4607@!@:display_}{\&{display} primitive@> 4608primitive("endgroup",end_group,0); 4609 eqtb[frozen_end_group]:=eqtb[cur_sym]; eg_loc:=cur_sym;@/ 4610@!@:endgroup_}{\&{endgroup} primitive@> 4611primitive("everyjob",every_job_command,0);@/ 4612@!@:every_job_}{\&{everyjob} primitive@> 4613primitive("exitif",exit_test,0);@/ 4614@!@:exit_if_}{\&{exitif} primitive@> 4615primitive("expandafter",expand_after,0);@/ 4616@!@:expand_after_}{\&{expandafter} primitive@> 4617primitive("from",from_token,0);@/ 4618@!@:from_}{\&{from} primitive@> 4619primitive("inwindow",in_window,0);@/ 4620@!@:in_window_}{\&{inwindow} primitive@> 4621primitive("interim",interim_command,0);@/ 4622@!@:interim_}{\&{interim} primitive@> 4623primitive("let",let_command,0);@/ 4624@!@:let_}{\&{let} primitive@> 4625primitive("newinternal",new_internal,0);@/ 4626@!@:new_internal_}{\&{newinternal} primitive@> 4627primitive("of",of_token,0);@/ 4628@!@:of_}{\&{of} primitive@> 4629primitive("openwindow",open_window,0);@/ 4630@!@:open_window_}{\&{openwindow} primitive@> 4631primitive("randomseed",random_seed,0);@/ 4632@!@:random_seed_}{\&{randomseed} primitive@> 4633primitive("save",save_command,0);@/ 4634@!@:save_}{\&{save} primitive@> 4635primitive("scantokens",scan_tokens,0);@/ 4636@!@:scan_tokens_}{\&{scantokens} primitive@> 4637primitive("shipout",ship_out_command,0);@/ 4638@!@:ship_out_}{\&{shipout} primitive@> 4639primitive("skipto",skip_to,0);@/ 4640@!@:skip_to_}{\&{skipto} primitive@> 4641primitive("step",step_token,0);@/ 4642@!@:step_}{\&{step} primitive@> 4643primitive("str",str_op,0);@/ 4644@!@:str_}{\&{str} primitive@> 4645primitive("tension",tension,0);@/ 4646@!@:tension_}{\&{tension} primitive@> 4647primitive("to",to_token,0);@/ 4648@!@:to_}{\&{to} primitive@> 4649primitive("until",until_token,0);@/ 4650@!@:until_}{\&{until} primitive@> 4651 4652@ Each primitive has a corresponding inverse, so that it is possible to 4653display the cryptic numeric contents of |eqtb| in symbolic form. 4654Every call of |primitive| in this program is therefore accompanied by some 4655straightforward code that forms part of the |print_cmd_mod| routine 4656explained below. 4657 4658@<Cases of |print_cmd_mod| for symbolic printing of primitives@>= 4659add_to_command:print("addto"); 4660assignment:print(":="); 4661at_least:print("atleast"); 4662at_token:print("at"); 4663bchar_label:print("||:"); 4664begin_group:print("begingroup"); 4665colon:print(":"); 4666comma:print(","); 4667controls:print("controls"); 4668cull_command:print("cull"); 4669curl_command:print("curl"); 4670delimiters:print("delimiters"); 4671display_command:print("display"); 4672double_colon:print("::"); 4673end_group:print("endgroup"); 4674every_job_command:print("everyjob"); 4675exit_test:print("exitif"); 4676expand_after:print("expandafter"); 4677from_token:print("from"); 4678in_window:print("inwindow"); 4679interim_command:print("interim"); 4680left_brace:print("{"); 4681left_bracket:print("["); 4682let_command:print("let"); 4683new_internal:print("newinternal"); 4684of_token:print("of"); 4685open_window:print("openwindow"); 4686path_join:print(".."); 4687random_seed:print("randomseed"); 4688relax:print_char("\"); 4689right_brace:print("}"); 4690right_bracket:print("]"); 4691save_command:print("save"); 4692scan_tokens:print("scantokens"); 4693semicolon:print(";"); 4694ship_out_command:print("shipout"); 4695skip_to:print("skipto"); 4696step_token:print("step"); 4697str_op:print("str"); 4698tension:print("tension"); 4699to_token:print("to"); 4700until_token:print("until"); 4701 4702@ We will deal with the other primitives later, at some point in the program 4703where their |eq_type| and |equiv| values are more meaningful. For example, 4704the primitives for macro definitions will be loaded when we consider the 4705routines that define macros. 4706It is easy to find where each particular 4707primitive was treated by looking in the index at the end; for example, the 4708section where |"def"| entered |eqtb| is listed under `\&{def} primitive'. 4709 4710@* \[14] Token lists. 4711A \MF\ token is either symbolic or numeric or a string, or it denotes 4712a macro parameter or capsule; so there are five corresponding ways to encode it 4713@^token@> 4714internally: (1)~A symbolic token whose hash code is~|p| 4715is represented by the number |p|, in the |info| field of a single-word 4716node in~|mem|. (2)~A numeric token whose |scaled| value is~|v| is 4717represented in a two-word node of~|mem|; the |type| field is |known|, 4718the |name_type| field is |token|, and the |value| field holds~|v|. 4719The fact that this token appears in a two-word node rather than a 4720one-word node is, of course, clear from the node address. 4721(3)~A string token is also represented in a two-word node; the |type| 4722field is |string_type|, the |name_type| field is |token|, and the 4723|value| field holds the corresponding |str_number|. (4)~Capsules have 4724|name_type=capsule|, and their |type| and |value| fields represent 4725arbitrary values (in ways to be explained later). (5)~Macro parameters 4726are like symbolic tokens in that they appear in |info| fields of 4727one-word nodes. The $k$th parameter is represented by |expr_base+k| if it 4728is of type \&{expr}, or by |suffix_base+k| if it is of type \&{suffix}, or 4729by |text_base+k| if it is of type \&{text}. (Here |0<=k<param_size|.) 4730Actual values of these parameters are kept in a separate stack, as we will 4731see later. The constants |expr_base|, |suffix_base|, and |text_base| are, 4732of course, chosen so that there will be no confusion between symbolic 4733tokens and parameters of various types. 4734 4735It turns out that |value(null)=0|, because |null=null_coords|; 4736we will make use of this coincidence later. 4737 4738Incidentally, while we're speaking of coincidences, we might note that 4739the `\\{type}' field of a node has nothing to do with ``type'' in a 4740printer's sense. It's curious that the same word is used in such different ways. 4741 4742@d type(#) == mem[#].hh.b0 {identifies what kind of value this is} 4743@d name_type(#) == mem[#].hh.b1 {a clue to the name of this value} 4744@d token_node_size=2 {the number of words in a large token node} 4745@d value_loc(#)==#+1 {the word that contains the |value| field} 4746@d value(#)==mem[value_loc(#)].int {the value stored in a large token node} 4747@d expr_base==hash_end+1 {code for the zeroth \&{expr} parameter} 4748@d suffix_base==expr_base+param_size {code for the zeroth \&{suffix} parameter} 4749@d text_base==suffix_base+param_size {code for the zeroth \&{text} parameter} 4750 4751@<Check the ``constant''...@>= 4752if text_base+param_size>max_halfword then bad:=22; 4753 4754@ A numeric token is created by the following trivial routine. 4755 4756@p function new_num_tok(@!v:scaled):pointer; 4757var @!p:pointer; {the new node} 4758begin p:=get_node(token_node_size); value(p):=v; 4759type(p):=known; name_type(p):=token; new_num_tok:=p; 4760end; 4761 4762@ A token list is a singly linked list of nodes in |mem|, where 4763each node contains a token and a link. Here's a subroutine that gets rid 4764of a token list when it is no longer needed. 4765 4766@p procedure@?token_recycle; forward;@t\2@>@;@/ 4767procedure flush_token_list(@!p:pointer); 4768var @!q:pointer; {the node being recycled} 4769begin while p<>null do 4770 begin q:=p; p:=link(p); 4771 if q>=hi_mem_min then free_avail(q) 4772 else begin case type(q) of 4773 vacuous,boolean_type,known:do_nothing; 4774 string_type:delete_str_ref(value(q)); 4775 unknown_types,pen_type,path_type,future_pen,picture_type, 4776 pair_type,transform_type,dependent,proto_dependent,independent: 4777 begin g_pointer:=q; token_recycle; 4778 end; 4779 othercases confusion("token") 4780@:this can't happen token}{\quad token@> 4781 endcases;@/ 4782 free_node(q,token_node_size); 4783 end; 4784 end; 4785end; 4786 4787@ The procedure |show_token_list|, which prints a symbolic form of 4788the token list that starts at a given node |p|, illustrates these 4789conventions. The token list being displayed should not begin with a reference 4790count. However, the procedure is intended to be fairly robust, so that if the 4791memory links are awry or if |p| is not really a pointer to a token list, 4792almost nothing catastrophic can happen. 4793 4794An additional parameter |q| is also given; this parameter is either null 4795or it points to a node in the token list where a certain magic computation 4796takes place that will be explained later. (Basically, |q| is non-null when 4797we are printing the two-line context information at the time of an error 4798message; |q| marks the place corresponding to where the second line 4799should begin.) 4800 4801The generation will stop, and `\.{\char`\ ETC.}' will be printed, if the length 4802of printing exceeds a given limit~|l|; the length of printing upon entry is 4803assumed to be a given amount called |null_tally|. (Note that 4804|show_token_list| sometimes uses itself recursively to print 4805variable names within a capsule.) 4806@^recursion@> 4807 4808Unusual entries are printed in the form of all-caps tokens 4809preceded by a space, e.g., `\.{\char`\ BAD}'. 4810 4811@<Declare the procedure called |show_token_list|@>= 4812procedure@?print_capsule; forward; @t\2@>@;@/ 4813procedure show_token_list(@!p,@!q:integer;@!l,@!null_tally:integer); 4814label exit; 4815var @!class,@!c:small_number; {the |char_class| of previous and new tokens} 4816@!r,@!v:integer; {temporary registers} 4817begin class:=percent_class; 4818tally:=null_tally; 4819while (p<>null) and (tally<l) do 4820 begin if p=q then @<Do magic computation@>; 4821 @<Display token |p| and set |c| to its class; 4822 but |return| if there are problems@>; 4823 class:=c; p:=link(p); 4824 end; 4825if p<>null then print(" ETC."); 4826@.ETC@> 4827exit: 4828end; 4829 4830@ @<Display token |p| and set |c| to its class...@>= 4831c:=letter_class; {the default} 4832if (p<mem_min)or(p>mem_end) then 4833 begin print(" CLOBBERED"); return; 4834@.CLOBBERED@> 4835 end; 4836if p<hi_mem_min then @<Display two-word token@> 4837else begin r:=info(p); 4838 if r>=expr_base then @<Display a parameter token@> 4839 else if r<1 then 4840 if r=0 then @<Display a collective subscript@> 4841 else print(" IMPOSSIBLE") 4842@.IMPOSSIBLE@> 4843 else begin r:=text(r); 4844 if (r<0)or(r>=str_ptr) then print(" NONEXISTENT") 4845@.NONEXISTENT@> 4846 else @<Print string |r| as a symbolic token 4847 and set |c| to its class@>; 4848 end; 4849 end 4850 4851@ @<Display two-word token@>= 4852if name_type(p)=token then 4853 if type(p)=known then @<Display a numeric token@> 4854 else if type(p)<>string_type then print(" BAD") 4855@.BAD@> 4856 else begin print_char(""""); slow_print(value(p)); print_char(""""); 4857 c:=string_class; 4858 end 4859else if (name_type(p)<>capsule)or(type(p)<vacuous)or(type(p)>independent) then 4860 print(" BAD") 4861else begin g_pointer:=p; print_capsule; c:=right_paren_class; 4862 end 4863 4864@ @<Display a numeric token@>= 4865begin if class=digit_class then print_char(" "); 4866v:=value(p); 4867if v<0 then 4868 begin if class=left_bracket_class then print_char(" "); 4869 print_char("["); print_scaled(v); print_char("]"); 4870 c:=right_bracket_class; 4871 end 4872else begin print_scaled(v); c:=digit_class; 4873 end; 4874end 4875 4876@ Strictly speaking, a genuine token will never have |info(p)=0|. 4877But we will see later (in the |print_variable_name| routine) that 4878it is convenient to let |info(p)=0| stand for `\.{[]}'. 4879 4880@<Display a collective subscript@>= 4881begin if class=left_bracket_class then print_char(" "); 4882print("[]"); c:=right_bracket_class; 4883end 4884 4885@ @<Display a parameter token@>= 4886begin if r<suffix_base then 4887 begin print("(EXPR"); r:=r-(expr_base); 4888@.EXPR@> 4889 end 4890else if r<text_base then 4891 begin print("(SUFFIX"); r:=r-(suffix_base); 4892@.SUFFIX@> 4893 end 4894else begin print("(TEXT"); r:=r-(text_base); 4895@.TEXT@> 4896 end; 4897print_int(r); print_char(")"); c:=right_paren_class; 4898end 4899 4900@ @<Print string |r| as a symbolic token...@>= 4901begin c:=char_class[so(str_pool[str_start[r]])]; 4902if c=class then 4903 case c of 4904 letter_class:print_char("."); 4905 isolated_classes:do_nothing; 4906 othercases print_char(" ") 4907 endcases; 4908slow_print(r); 4909end 4910 4911@ The following procedures have been declared |forward| with no parameters, 4912because the author dislikes \PASCAL's convention about |forward| procedures 4913with parameters. It was necessary to do something, because |show_token_list| 4914is recursive (although the recursion is limited to one level), and because 4915|flush_token_list| is syntactically (but not semantically) recursive. 4916@^recursion@> 4917 4918@<Declare miscellaneous procedures that were declared |forward|@>= 4919procedure print_capsule; 4920begin print_char("("); print_exp(g_pointer,0); print_char(")"); 4921end; 4922@# 4923procedure token_recycle; 4924begin recycle_value(g_pointer); 4925end; 4926 4927@ @<Glob...@>= 4928@!g_pointer:pointer; {(global) parameter to the |forward| procedures} 4929 4930@ Macro definitions are kept in \MF's memory in the form of token lists 4931that have a few extra one-word nodes at the beginning. 4932 4933The first node contains a reference count that is used to tell when the 4934list is no longer needed. To emphasize the fact that a reference count is 4935present, we shall refer to the |info| field of this special node as the 4936|ref_count| field. 4937@^reference counts@> 4938 4939The next node or nodes after the reference count serve to describe the 4940formal parameters. They consist of zero or more parameter tokens followed 4941by a code for the type of macro. 4942 4943@d ref_count==info {reference count preceding a macro definition or pen header} 4944@d add_mac_ref(#)==incr(ref_count(#)) {make a new reference to a macro list} 4945@d general_macro=0 {preface to a macro defined with a parameter list} 4946@d primary_macro=1 {preface to a macro with a \&{primary} parameter} 4947@d secondary_macro=2 {preface to a macro with a \&{secondary} parameter} 4948@d tertiary_macro=3 {preface to a macro with a \&{tertiary} parameter} 4949@d expr_macro=4 {preface to a macro with an undelimited \&{expr} parameter} 4950@d of_macro=5 {preface to a macro with 4951 undelimited `\&{expr} |x| \&{of}~|y|' parameters} 4952@d suffix_macro=6 {preface to a macro with an undelimited \&{suffix} parameter} 4953@d text_macro=7 {preface to a macro with an undelimited \&{text} parameter} 4954 4955@p procedure delete_mac_ref(@!p:pointer); 4956 {|p| points to the reference count of a macro list that is 4957 losing one reference} 4958begin if ref_count(p)=null then flush_token_list(p) 4959else decr(ref_count(p)); 4960end; 4961 4962@ The following subroutine displays a macro, given a pointer to its 4963reference count. 4964 4965@p @t\4@>@<Declare the procedure called |print_cmd_mod|@>@; 4966procedure show_macro(@!p:pointer;@!q,@!l:integer); 4967label exit; 4968var @!r:pointer; {temporary storage} 4969begin p:=link(p); {bypass the reference count} 4970while info(p)>text_macro do 4971 begin r:=link(p); link(p):=null; 4972 show_token_list(p,null,l,0); link(p):=r; p:=r; 4973 if l>0 then l:=l-tally@+else return; 4974 end; {control printing of `\.{ETC.}'} 4975@.ETC@> 4976tally:=0; 4977case info(p) of 4978general_macro:print("->"); 4979@.->@> 4980primary_macro,secondary_macro,tertiary_macro:begin print_char("<"); 4981 print_cmd_mod(param_type,info(p)); print(">->"); 4982 end; 4983expr_macro:print("<expr>->"); 4984of_macro:print("<expr>of<primary>->"); 4985suffix_macro:print("<suffix>->"); 4986text_macro:print("<text>->"); 4987end; {there are no other cases} 4988show_token_list(link(p),q,l-tally,0); 4989exit:end; 4990 4991@* \[15] Data structures for variables. 4992The variables of \MF\ programs can be simple, like `\.x', or they can 4993combine the structural properties of arrays and records, like `\.{x20a.b}'. 4994A \MF\ user assigns a type to a variable like \.{x20a.b} by saying, for 4995example, `\.{boolean} \.{x[]a.b}'. It's time for us to study how such 4996things are represented inside of the computer. 4997 4998Each variable value occupies two consecutive words, either in a two-word 4999node called a value node, or as a two-word subfield of a larger node. One 5000of those two words is called the |value| field; it is an integer, 5001containing either a |scaled| numeric value or the representation of some 5002other type of quantity. (It might also be subdivided into halfwords, in 5003which case it is referred to by other names instead of |value|.) The other 5004word is broken into subfields called |type|, |name_type|, and |link|. The 5005|type| field is a quarterword that specifies the variable's type, and 5006|name_type| is a quarterword from which \MF\ can reconstruct the 5007variable's name (sometimes by using the |link| field as well). Thus, only 50081.25 words are actually devoted to the value itself; the other 5009three-quarters of a word are overhead, but they aren't wasted because they 5010allow \MF\ to deal with sparse arrays and to provide meaningful diagnostics. 5011 5012In this section we shall be concerned only with the structural aspects of 5013variables, not their values. Later parts of the program will change the 5014|type| and |value| fields, but we shall treat those fields as black boxes 5015whose contents should not be touched. 5016 5017However, if the |type| field is |structured|, there is no |value| field, 5018and the second word is broken into two pointer fields called |attr_head| 5019and |subscr_head|. Those fields point to additional nodes that 5020contain structural information, as we shall see. 5021 5022@d subscr_head_loc(#) == #+1 {where |value|, |subscr_head|, and |attr_head| are} 5023@d attr_head(#) == info(subscr_head_loc(#)) {pointer to attribute info} 5024@d subscr_head(#) == link(subscr_head_loc(#)) {pointer to subscript info} 5025@d value_node_size=2 {the number of words in a value node} 5026 5027@ An attribute node is three words long. Two of these words contain |type| 5028and |value| fields as described above, and the third word contains 5029additional information: There is an |attr_loc| field, which contains the 5030hash address of the token that names this attribute; and there's also a 5031|parent| field, which points to the value node of |structured| type at the 5032next higher level (i.e., at the level to which this attribute is 5033subsidiary). The |name_type| in an attribute node is `|attr|'. The 5034|link| field points to the next attribute with the same parent; these are 5035arranged in increasing order, so that |attr_loc(link(p))>attr_loc(p)|. The 5036final attribute node links to the constant |end_attr|, whose |attr_loc| 5037field is greater than any legal hash address. The |attr_head| in the 5038parent points to a node whose |name_type| is |structured_root|; this 5039node represents the null attribute, i.e., the variable that is relevant 5040when no attributes are attached to the parent. The |attr_head| node 5041has the fields of either 5042a value node, a subscript node, or an attribute node, depending on what 5043the parent would be if it were not structured; but the subscript and 5044attribute fields are ignored, so it effectively contains only the data of 5045a value node. The |link| field in this special node points to an attribute 5046node whose |attr_loc| field is zero; the latter node represents a collective 5047subscript `\.{[]}' attached to the parent, and its |link| field points to 5048the first non-special attribute node (or to |end_attr| if there are none). 5049 5050A subscript node likewise occupies three words, with |type| and |value| fields 5051plus extra information; its |name_type| is |subscr|. In this case the 5052third word is called the |subscript| field, which is a |scaled| integer. 5053The |link| field points to the subscript node with the next larger 5054subscript, if any; otherwise the |link| points to the attribute node 5055for collective subscripts at this level. We have seen that the latter node 5056contains an upward pointer, so that the parent can be deduced. 5057 5058The |name_type| in a parent-less value node is |root|, and the |link| 5059is the hash address of the token that names this value. 5060 5061In other words, variables have a hierarchical structure that includes 5062enough threads running around so that the program is able to move easily 5063between siblings, parents, and children. An example should be helpful: 5064(The reader is advised to draw a picture while reading the following 5065description, since that will help to firm up the ideas.) 5066Suppose that `\.x' and `\.{x.a}' and `\.{x[]b}' and `\.{x5}' 5067and `\.{x20b}' have been mentioned in a user's program, where 5068\.{x[]b} has been declared to be of \&{boolean} type. Let |h(x)|, |h(a)|, 5069and |h(b)| be the hash addresses of \.x, \.a, and~\.b. Then 5070|eq_type(h(x))=tag_token| and |equiv(h(x))=p|, where |p|~is a two-word value 5071node with |name_type(p)=root| and |link(p)=h(x)|. We have |type(p)=structured|, 5072|attr_head(p)=q|, and |subscr_head(p)=r|, where |q| points to a value 5073node and |r| to a subscript node. (Are you still following this? Use 5074a pencil to draw a diagram.) The lone variable `\.x' is represented by 5075|type(q)| and |value(q)|; furthermore 5076|name_type(q)=structured_root| and |link(q)=q1|, where |q1| points 5077to an attribute node representing `\.{x[]}'. Thus |name_type(q1)=attr|, 5078|attr_loc(q1)=collective_subscript=0|, |parent(q1)=p|, 5079|type(q1)=structured|, |attr_head(q1)=qq|, and |subscr_head(q1)=qq1|; 5080|qq| is a three-word ``attribute-as-value'' node with |type(qq)=numeric_type| 5081(assuming that \.{x5} is numeric, because |qq| represents `\.{x[]}' 5082with no further attributes), |name_type(qq)=structured_root|, 5083|attr_loc(qq)=0|, |parent(qq)=p|, and 5084|link(qq)=qq1|. (Now pay attention to the next part.) Node |qq1| is 5085an attribute node representing `\.{x[][]}', which has never yet 5086occurred; its |type| field is |undefined|, and its |value| field is 5087undefined. We have |name_type(qq1)=attr|, |attr_loc(qq1)=collective_subscript|, 5088|parent(qq1)=q1|, and |link(qq1)=qq2|. Since |qq2| represents 5089`\.{x[]b}', |type(qq2)=unknown_boolean|; also |attr_loc(qq2)=h(b)|, 5090|parent(qq2)=q1|, |name_type(qq2)=attr|, |link(qq2)=end_attr|. 5091(Maybe colored lines will help untangle your picture.) 5092 Node |r| is a subscript node with |type| and |value| 5093representing `\.{x5}'; |name_type(r)=subscr|, |subscript(r)=5.0|, 5094and |link(r)=r1| is another subscript node. To complete the picture, 5095see if you can guess what |link(r1)| is; give up? It's~|q1|. 5096Furthermore |subscript(r1)=20.0|, |name_type(r1)=subscr|, 5097|type(r1)=structured|, |attr_head(r1)=qqq|, |subscr_head(r1)=qqq1|, 5098and we finish things off with three more nodes 5099|qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again 5100with a larger sheet of paper.) The value of variable `\.{x20b}' 5101appears in node~|qqq2=link(qqq1)|, as you can well imagine. 5102Similarly, the value of `\.{x.a}' appears in node |q2=link(q1)|, where 5103|attr_loc(q2)=h(a)| and |parent(q2)=p|. 5104 5105If the example in the previous paragraph doesn't make things crystal 5106clear, a glance at some of the simpler subroutines below will reveal how 5107things work out in practice. 5108 5109The only really unusual thing about these conventions is the use of 5110collective subscript attributes. The idea is to avoid repeating a lot of 5111type information when many elements of an array are identical macros 5112(for which distinct values need not be stored) or when they don't have 5113all of the possible attributes. Branches of the structure below collective 5114subscript attributes do not carry actual values except for macro identifiers; 5115branches of the structure below subscript nodes do not carry significant 5116information in their collective subscript attributes. 5117 5118@d attr_loc_loc(#)==#+2 {where the |attr_loc| and |parent| fields are} 5119@d attr_loc(#)==info(attr_loc_loc(#)) {hash address of this attribute} 5120@d parent(#)==link(attr_loc_loc(#)) {pointer to |structured| variable} 5121@d subscript_loc(#)==#+2 {where the |subscript| field lives} 5122@d subscript(#)==mem[subscript_loc(#)].sc {subscript of this variable} 5123@d attr_node_size=3 {the number of words in an attribute node} 5124@d subscr_node_size=3 {the number of words in a subscript node} 5125@d collective_subscript=0 {code for the attribute `\.{[]}'} 5126 5127@<Initialize table...@>= 5128attr_loc(end_attr):=hash_end+1; parent(end_attr):=null; 5129 5130@ Variables of type \&{pair} will have values that point to four-word 5131nodes containing two numeric values. The first of these values has 5132|name_type=x_part_sector| and the second has |name_type=y_part_sector|; 5133the |link| in the first points back to the node whose |value| points 5134to this four-word node. 5135 5136Variables of type \&{transform} are similar, but in this case their 5137|value| points to a 12-word node containing six values, identified by 5138|x_part_sector|, |y_part_sector|, |xx_part_sector|, |xy_part_sector|, 5139|yx_part_sector|, and |yy_part_sector|. 5140 5141When an entire structured variable is saved, the |root| indication 5142is temporarily replaced by |saved_root|. 5143 5144Some variables have no name; they just are used for temporary storage 5145while expressions are being evaluated. We call them {\sl capsules}. 5146 5147@d x_part_loc(#)==# {where the \&{xpart} is found in a pair or transform node} 5148@d y_part_loc(#)==#+2 {where the \&{ypart} is found in a pair or transform node} 5149@d xx_part_loc(#)==#+4 {where the \&{xxpart} is found in a transform node} 5150@d xy_part_loc(#)==#+6 {where the \&{xypart} is found in a transform node} 5151@d yx_part_loc(#)==#+8 {where the \&{yxpart} is found in a transform node} 5152@d yy_part_loc(#)==#+10 {where the \&{yypart} is found in a transform node} 5153@# 5154@d pair_node_size=4 {the number of words in a pair node} 5155@d transform_node_size=12 {the number of words in a transform node} 5156 5157@<Glob...@>= 5158@!big_node_size:array[transform_type..pair_type] of small_number; 5159 5160@ The |big_node_size| array simply contains two constants that \MF\ 5161occasionally needs to know. 5162 5163@<Set init...@>= 5164big_node_size[transform_type]:=transform_node_size; 5165big_node_size[pair_type]:=pair_node_size; 5166 5167@ If |type(p)=pair_type| or |transform_type| and if |value(p)=null|, the 5168procedure call |init_big_node(p)| will allocate a pair or transform node 5169for~|p|. The individual parts of such nodes are initially of type 5170|independent|. 5171 5172@p procedure init_big_node(@!p:pointer); 5173var @!q:pointer; {the new node} 5174@!s:small_number; {its size} 5175begin s:=big_node_size[type(p)]; q:=get_node(s); 5176repeat s:=s-2; @<Make variable |q+s| newly independent@>; 5177name_type(q+s):=half(s)+x_part_sector; link(q+s):=null; 5178until s=0; 5179link(q):=p; value(p):=q; 5180end; 5181 5182@ The |id_transform| function creates a capsule for the 5183identity transformation. 5184 5185@p function id_transform:pointer; 5186var @!p,@!q,@!r:pointer; {list manipulation registers} 5187begin p:=get_node(value_node_size); type(p):=transform_type; 5188name_type(p):=capsule; value(p):=null; init_big_node(p); q:=value(p); 5189r:=q+transform_node_size; 5190repeat r:=r-2; 5191type(r):=known; value(r):=0; 5192until r=q; 5193value(xx_part_loc(q)):=unity; value(yy_part_loc(q)):=unity; 5194id_transform:=p; 5195end; 5196 5197@ Tokens are of type |tag_token| when they first appear, but they point 5198to |null| until they are first used as the root of a variable. 5199The following subroutine establishes the root node on such grand occasions. 5200 5201@p procedure new_root(@!x:pointer); 5202var @!p:pointer; {the new node} 5203begin p:=get_node(value_node_size); type(p):=undefined; name_type(p):=root; 5204link(p):=x; equiv(x):=p; 5205end; 5206 5207@ These conventions for variable representation are illustrated by the 5208|print_variable_name| routine, which displays the full name of a 5209variable given only a pointer to its two-word value packet. 5210 5211@p procedure print_variable_name(@!p:pointer); 5212label found,exit; 5213var @!q:pointer; {a token list that will name the variable's suffix} 5214@!r:pointer; {temporary for token list creation} 5215begin while name_type(p)>=x_part_sector do 5216 @<Preface the output with a part specifier; |return| in the 5217 case of a capsule@>; 5218q:=null; 5219while name_type(p)>saved_root do 5220 @<Ascend one level, pushing a token onto list |q| 5221 and replacing |p| by its parent@>; 5222r:=get_avail; info(r):=link(p); link(r):=q; 5223if name_type(p)=saved_root then print("(SAVED)"); 5224@.SAVED@> 5225show_token_list(r,null,el_gordo,tally); flush_token_list(r); 5226exit:end; 5227 5228@ @<Ascend one level, pushing a token onto list |q|...@>= 5229begin if name_type(p)=subscr then 5230 begin r:=new_num_tok(subscript(p)); 5231 repeat p:=link(p); 5232 until name_type(p)=attr; 5233 end 5234else if name_type(p)=structured_root then 5235 begin p:=link(p); goto found; 5236 end 5237else begin if name_type(p)<>attr then confusion("var"); 5238@:this can't happen var}{\quad var@> 5239 r:=get_avail; info(r):=attr_loc(p); 5240 end; 5241link(r):=q; q:=r; 5242found: p:=parent(p); 5243end 5244 5245@ @<Preface the output with a part specifier...@>= 5246begin case name_type(p) of 5247x_part_sector: print_char("x"); 5248y_part_sector: print_char("y"); 5249xx_part_sector: print("xx"); 5250xy_part_sector: print("xy"); 5251yx_part_sector: print("yx"); 5252yy_part_sector: print("yy"); 5253capsule: begin print("%CAPSULE"); print_int(p-null); return; 5254@.CAPSULE@> 5255 end; 5256end; {there are no other cases} 5257print("part "); p:=link(p-2*(name_type(p)-x_part_sector)); 5258end 5259 5260@ The |interesting| function returns |true| if a given variable is not 5261in a capsule, or if the user wants to trace capsules. 5262 5263@p function interesting(@!p:pointer):boolean; 5264var @!t:small_number; {a |name_type|} 5265begin if internal[tracing_capsules]>0 then interesting:=true 5266else begin t:=name_type(p); 5267 if t>=x_part_sector then if t<>capsule then 5268 t:=name_type(link(p-2*(t-x_part_sector))); 5269 interesting:=(t<>capsule); 5270 end; 5271end; 5272 5273@ Now here is a subroutine that converts an unstructured type into an 5274equivalent structured type, by inserting a |structured| node that is 5275capable of growing. This operation is done only when |name_type(p)=root|, 5276|subscr|, or |attr|. 5277 5278The procedure returns a pointer to the new node that has taken node~|p|'s 5279place in the structure. Node~|p| itself does not move, nor are its 5280|value| or |type| fields changed in any way. 5281 5282@p function new_structure(@!p:pointer):pointer; 5283var @!q,@!r:pointer; {list manipulation registers} 5284begin case name_type(p) of 5285root: begin q:=link(p); r:=get_node(value_node_size); equiv(q):=r; 5286 end; 5287subscr: @<Link a new subscript node |r| in place of node |p|@>; 5288attr: @<Link a new attribute node |r| in place of node |p|@>; 5289othercases confusion("struct") 5290@:this can't happen struct}{\quad struct@> 5291endcases;@/ 5292link(r):=link(p); type(r):=structured; name_type(r):=name_type(p); 5293attr_head(r):=p; name_type(p):=structured_root;@/ 5294q:=get_node(attr_node_size); link(p):=q; subscr_head(r):=q; 5295parent(q):=r; type(q):=undefined; name_type(q):=attr; link(q):=end_attr; 5296attr_loc(q):=collective_subscript; new_structure:=r; 5297end; 5298 5299@ @<Link a new subscript node |r| in place of node |p|@>= 5300begin q:=p; 5301repeat q:=link(q); 5302until name_type(q)=attr; 5303q:=parent(q); r:=subscr_head_loc(q); {|link(r)=subscr_head(q)|} 5304repeat q:=r; r:=link(r); 5305until r=p; 5306r:=get_node(subscr_node_size); 5307link(q):=r; subscript(r):=subscript(p); 5308end 5309 5310@ If the attribute is |collective_subscript|, there are two pointers to 5311node~|p|, so we must change both of them. 5312 5313@<Link a new attribute node |r| in place of node |p|@>= 5314begin q:=parent(p); r:=attr_head(q); 5315repeat q:=r; r:=link(r); 5316until r=p; 5317r:=get_node(attr_node_size); link(q):=r;@/ 5318mem[attr_loc_loc(r)]:=mem[attr_loc_loc(p)]; {copy |attr_loc| and |parent|} 5319if attr_loc(p)=collective_subscript then 5320 begin q:=subscr_head_loc(parent(p)); 5321 while link(q)<>p do q:=link(q); 5322 link(q):=r; 5323 end; 5324end 5325 5326@ The |find_variable| routine is given a pointer~|t| to a nonempty token 5327list of suffixes; it returns a pointer to the corresponding two-word 5328value. For example, if |t| points to token \.x followed by a numeric 5329token containing the value~7, |find_variable| finds where the value of 5330\.{x7} is stored in memory. This may seem a simple task, and it 5331usually is, except when \.{x7} has never been referenced before. 5332Indeed, \.x may never have even been subscripted before; complexities 5333arise with respect to updating the collective subscript information. 5334 5335If a macro type is detected anywhere along path~|t|, or if the first 5336item on |t| isn't a |tag_token|, the value |null| is returned. 5337Otherwise |p| will be a non-null pointer to a node such that 5338|undefined<type(p)<structured|. 5339 5340@d abort_find==begin find_variable:=null; return;@+end 5341 5342@p function find_variable(@!t:pointer):pointer; 5343label exit; 5344var @!p,@!q,@!r,@!s:pointer; {nodes in the ``value'' line} 5345@!pp,@!qq,@!rr,@!ss:pointer; {nodes in the ``collective'' line} 5346@!n:integer; {subscript or attribute} 5347@!save_word:memory_word; {temporary storage for a word of |mem|} 5348@^inner loop@> 5349begin p:=info(t); t:=link(t); 5350if eq_type(p) mod outer_tag<>tag_token then abort_find; 5351if equiv(p)=null then new_root(p); 5352p:=equiv(p); pp:=p; 5353while t<>null do 5354 begin @<Make sure that both nodes |p| and |pp| are of |structured| type@>; 5355 if t<hi_mem_min then 5356 @<Descend one level for the subscript |value(t)|@> 5357 else @<Descend one level for the attribute |info(t)|@>; 5358 t:=link(t); 5359 end; 5360if type(pp)>=structured then 5361 if type(pp)=structured then pp:=attr_head(pp)@+else abort_find; 5362if type(p)=structured then p:=attr_head(p); 5363if type(p)=undefined then 5364 begin if type(pp)=undefined then 5365 begin type(pp):=numeric_type; value(pp):=null; 5366 end; 5367 type(p):=type(pp); value(p):=null; 5368 end; 5369find_variable:=p; 5370exit:end; 5371 5372@ Although |pp| and |p| begin together, they diverge when a subscript occurs; 5373|pp|~stays in the collective line while |p|~goes through actual subscript 5374values. 5375 5376@<Make sure that both nodes |p| and |pp|...@>= 5377if type(pp)<>structured then 5378 begin if type(pp)>structured then abort_find; 5379 ss:=new_structure(pp); 5380 if p=pp then p:=ss; 5381 pp:=ss; 5382 end; {now |type(pp)=structured|} 5383if type(p)<>structured then {it cannot be |>structured|} 5384 p:=new_structure(p) {now |type(p)=structured|} 5385 5386@ We want this part of the program to be reasonably fast, in case there are 5387@^inner loop@> 5388lots of subscripts at the same level of the data structure. Therefore 5389we store an ``infinite'' value in the word that appears at the end of the 5390subscript list, even though that word isn't part of a subscript node. 5391 5392@<Descend one level for the subscript |value(t)|@>= 5393begin n:=value(t); 5394pp:=link(attr_head(pp)); {now |attr_loc(pp)=collective_subscript|} 5395q:=link(attr_head(p)); save_word:=mem[subscript_loc(q)]; 5396subscript(q):=el_gordo; s:=subscr_head_loc(p); {|link(s)=subscr_head(p)|} 5397repeat r:=s; s:=link(s); 5398until n<=subscript(s); 5399if n=subscript(s) then p:=s 5400else begin p:=get_node(subscr_node_size); link(r):=p; link(p):=s; 5401 subscript(p):=n; name_type(p):=subscr; type(p):=undefined; 5402 end; 5403mem[subscript_loc(q)]:=save_word; 5404end 5405 5406@ @<Descend one level for the attribute |info(t)|@>= 5407begin n:=info(t); 5408ss:=attr_head(pp); 5409repeat rr:=ss; ss:=link(ss); 5410until n<=attr_loc(ss); 5411if n<attr_loc(ss) then 5412 begin qq:=get_node(attr_node_size); link(rr):=qq; link(qq):=ss; 5413 attr_loc(qq):=n; name_type(qq):=attr; type(qq):=undefined; 5414 parent(qq):=pp; ss:=qq; 5415 end; 5416if p=pp then 5417 begin p:=ss; pp:=ss; 5418 end 5419else begin pp:=ss; s:=attr_head(p); 5420 repeat r:=s; s:=link(s); 5421 until n<=attr_loc(s); 5422 if n=attr_loc(s) then p:=s 5423 else begin q:=get_node(attr_node_size); link(r):=q; link(q):=s; 5424 attr_loc(q):=n; name_type(q):=attr; type(q):=undefined; 5425 parent(q):=p; p:=q; 5426 end; 5427 end; 5428end 5429 5430@ Variables lose their former values when they appear in a type declaration, 5431or when they are defined to be macros or \&{let} equal to something else. 5432A subroutine will be defined later that recycles the storage associated 5433with any particular |type| or |value|; our goal now is to study a higher 5434level process called |flush_variable|, which selectively frees parts of a 5435variable structure. 5436 5437This routine has some complexity because of examples such as 5438`\hbox{\tt numeric x[]a[]b}', 5439which recycles all variables of the form \.{x[i]a[j]b} (and no others), while 5440`\hbox{\tt vardef x[]a[]=...}' 5441discards all variables of the form \.{x[i]a[j]} followed by an arbitrary 5442suffix, except for the collective node \.{x[]a[]} itself. The obvious way 5443to handle such examples is to use recursion; so that's what we~do. 5444@^recursion@> 5445 5446Parameter |p| points to the root information of the variable; 5447parameter |t| points to a list of one-word nodes that represent 5448suffixes, with |info=collective_subscript| for subscripts. 5449 5450@p @t\4@>@<Declare subroutines for printing expressions@>@;@/ 5451@t\4@>@<Declare basic dependency-list subroutines@>@; 5452@t\4@>@<Declare the recycling subroutines@>@; 5453@t\4@>@<Declare the procedure called |flush_cur_exp|@>@; 5454@t\4@>@<Declare the procedure called |flush_below_variable|@>@; 5455procedure flush_variable(@!p,@!t:pointer;@!discard_suffixes:boolean); 5456label exit; 5457var @!q,@!r:pointer; {list manipulation} 5458@!n:halfword; {attribute to match} 5459begin while t<>null do 5460 begin if type(p)<>structured then return; 5461 n:=info(t); t:=link(t); 5462 if n=collective_subscript then 5463 begin r:=subscr_head_loc(p); q:=link(r); {|q=subscr_head(p)|} 5464 while name_type(q)=subscr do 5465 begin flush_variable(q,t,discard_suffixes); 5466 if t=null then 5467 if type(q)=structured then r:=q 5468 else begin link(r):=link(q); free_node(q,subscr_node_size); 5469 end 5470 else r:=q; 5471 q:=link(r); 5472 end; 5473 end; 5474 p:=attr_head(p); 5475 repeat r:=p; p:=link(p); 5476 until attr_loc(p)>=n; 5477 if attr_loc(p)<>n then return; 5478 end; 5479if discard_suffixes then flush_below_variable(p) 5480else begin if type(p)=structured then p:=attr_head(p); 5481 recycle_value(p); 5482 end; 5483exit:end; 5484 5485@ The next procedure is simpler; it wipes out everything but |p| itself, 5486which becomes undefined. 5487 5488@<Declare the procedure called |flush_below_variable|@>= 5489procedure flush_below_variable(@!p:pointer); 5490var @!q,@!r:pointer; {list manipulation registers} 5491begin if type(p)<>structured then 5492 recycle_value(p) {this sets |type(p)=undefined|} 5493else begin q:=subscr_head(p); 5494 while name_type(q)=subscr do 5495 begin flush_below_variable(q); r:=q; q:=link(q); 5496 free_node(r,subscr_node_size); 5497 end; 5498 r:=attr_head(p); q:=link(r); recycle_value(r); 5499 if name_type(p)<=saved_root then free_node(r,value_node_size) 5500 else free_node(r,subscr_node_size); 5501 {we assume that |subscr_node_size=attr_node_size|} 5502 repeat flush_below_variable(q); r:=q; q:=link(q); free_node(r,attr_node_size); 5503 until q=end_attr; 5504 type(p):=undefined; 5505 end; 5506end; 5507 5508@ Just before assigning a new value to a variable, we will recycle the 5509old value and make the old value undefined. The |und_type| routine 5510determines what type of undefined value should be given, based on 5511the current type before recycling. 5512 5513@p function und_type(@!p:pointer):small_number; 5514begin case type(p) of 5515undefined,vacuous:und_type:=undefined; 5516boolean_type,unknown_boolean:und_type:=unknown_boolean; 5517string_type,unknown_string:und_type:=unknown_string; 5518pen_type,unknown_pen,future_pen:und_type:=unknown_pen; 5519path_type,unknown_path:und_type:=unknown_path; 5520picture_type,unknown_picture:und_type:=unknown_picture; 5521transform_type,pair_type,numeric_type:und_type:=type(p); 5522known,dependent,proto_dependent,independent:und_type:=numeric_type; 5523end; {there are no other cases} 5524end; 5525 5526@ The |clear_symbol| routine is used when we want to redefine the equivalent 5527of a symbolic token. It must remove any variable structure or macro 5528definition that is currently attached to that symbol. If the |saving| 5529parameter is true, a subsidiary structure is saved instead of destroyed. 5530 5531@p procedure clear_symbol(@!p:pointer;@!saving:boolean); 5532var @!q:pointer; {|equiv(p)|} 5533begin q:=equiv(p); 5534case eq_type(p) mod outer_tag of 5535defined_macro,secondary_primary_macro,tertiary_secondary_macro, 5536 expression_tertiary_macro: if not saving then delete_mac_ref(q); 5537tag_token:if q<>null then 5538 if saving then name_type(q):=saved_root 5539 else begin flush_below_variable(q); free_node(q,value_node_size); 5540 end;@; 5541othercases do_nothing 5542endcases;@/ 5543eqtb[p]:=eqtb[frozen_undefined]; 5544end; 5545 5546@* \[16] Saving and restoring equivalents. 5547The nested structure provided by \&{begingroup} and \&{endgroup} 5548allows |eqtb| entries to be saved and restored, so that temporary changes 5549can be made without difficulty. When the user requests a current value to 5550be saved, \MF\ puts that value into its ``save stack.'' An appearance of 5551\&{endgroup} ultimately causes the old values to be removed from the save 5552stack and put back in their former places. 5553 5554The save stack is a linked list containing three kinds of entries, 5555distinguished by their |info| fields. If |p| points to a saved item, 5556then 5557 5558\smallskip\hang 5559|info(p)=0| stands for a group boundary; each \&{begingroup} contributes 5560such an item to the save stack and each \&{endgroup} cuts back the stack 5561until the most recent such entry has been removed. 5562 5563\smallskip\hang 5564|info(p)=q|, where |1<=q<=hash_end|, means that |mem[p+1]| holds the former 5565contents of |eqtb[q]|. Such save stack entries are generated by \&{save} 5566commands. 5567 5568\smallskip\hang 5569|info(p)=hash_end+q|, where |q>0|, means that |value(p)| is a |scaled| 5570integer to be restored to internal parameter number~|q|. Such entries 5571are generated by \&{interim} commands. 5572 5573\smallskip\noindent 5574The global variable |save_ptr| points to the top item on the save stack. 5575 5576@d save_node_size=2 {number of words per non-boundary save-stack node} 5577@d saved_equiv(#)==mem[#+1].hh {where an |eqtb| entry gets saved} 5578@d save_boundary_item(#)==begin #:=get_avail; info(#):=0; 5579 link(#):=save_ptr; save_ptr:=#; 5580 end 5581 5582@<Glob...@>=@!save_ptr:pointer; {the most recently saved item} 5583 5584@ @<Set init...@>=save_ptr:=null; 5585 5586@ The |save_variable| routine is given a hash address |q|; it salts this 5587address in the save stack, together with its current equivalent, 5588then makes token~|q| behave as though it were brand new. 5589 5590Nothing is stacked when |save_ptr=null|, however; there's no way to remove 5591things from the stack when the program is not inside a group, so there's 5592no point in wasting the space. 5593 5594@p procedure save_variable(@!q:pointer); 5595var @!p:pointer; {temporary register} 5596begin if save_ptr<>null then 5597 begin p:=get_node(save_node_size); info(p):=q; link(p):=save_ptr; 5598 saved_equiv(p):=eqtb[q]; save_ptr:=p; 5599 end; 5600clear_symbol(q,(save_ptr<>null)); 5601end; 5602 5603@ Similarly, |save_internal| is given the location |q| of an internal 5604quantity like |tracing_pens|. It creates a save stack entry of the 5605third kind. 5606 5607@p procedure save_internal(@!q:halfword); 5608var @!p:pointer; {new item for the save stack} 5609begin if save_ptr<>null then 5610 begin p:=get_node(save_node_size); info(p):=hash_end+q; 5611 link(p):=save_ptr; value(p):=internal[q]; save_ptr:=p; 5612 end; 5613end; 5614 5615@ At the end of a group, the |unsave| routine restores all of the saved 5616equivalents in reverse order. This routine will be called only when there 5617is at least one boundary item on the save stack. 5618 5619@p procedure unsave; 5620var @!q:pointer; {index to saved item} 5621@!p:pointer; {temporary register} 5622begin while info(save_ptr)<>0 do 5623 begin q:=info(save_ptr); 5624 if q>hash_end then 5625 begin if internal[tracing_restores]>0 then 5626 begin begin_diagnostic; print_nl("{restoring "); 5627 slow_print(int_name[q-(hash_end)]); print_char("="); 5628 print_scaled(value(save_ptr)); print_char("}"); 5629 end_diagnostic(false); 5630 end; 5631 internal[q-(hash_end)]:=value(save_ptr); 5632 end 5633 else begin if internal[tracing_restores]>0 then 5634 begin begin_diagnostic; print_nl("{restoring "); 5635 slow_print(text(q)); print_char("}"); 5636 end_diagnostic(false); 5637 end; 5638 clear_symbol(q,false); 5639 eqtb[q]:=saved_equiv(save_ptr); 5640 if eq_type(q) mod outer_tag=tag_token then 5641 begin p:=equiv(q); 5642 if p<>null then name_type(p):=root; 5643 end; 5644 end; 5645 p:=link(save_ptr); free_node(save_ptr,save_node_size); save_ptr:=p; 5646 end; 5647p:=link(save_ptr); free_avail(save_ptr); save_ptr:=p; 5648end; 5649 5650@* \[17] Data structures for paths. 5651When a \MF\ user specifies a path, \MF\ will create a list of knots 5652and control points for the associated cubic spline curves. If the 5653knots are $z_0$, $z_1$, \dots, $z_n$, there are control points 5654$z_k^+$ and $z_{k+1}^-$ such that the cubic splines between knots 5655$z_k$ and $z_{k+1}$ are defined by B\'ezier's formula 5656@:Bezier}{B\'ezier, Pierre Etienne@> 5657$$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr 5658&=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$ 5659for |0<=t<=1|. 5660 5661There is a 7-word node for each knot $z_k$, containing one word of 5662control information and six words for the |x| and |y| coordinates 5663of $z_k^-$ and $z_k$ and~$z_k^+$. The control information appears 5664in the |left_type| and |right_type| fields, which each occupy 5665a quarter of the first word in the node; they specify properties 5666of the curve as it enters and leaves the knot. There's also a 5667halfword |link| field, which points to the following knot. 5668 5669If the path is a closed contour, knots 0 and |n| are identical; 5670i.e., the |link| in knot |n-1| points to knot~0. But if the path 5671is not closed, the |left_type| of knot~0 and the |right_type| of knot~|n| 5672are equal to |endpoint|. In the latter case the |link| in knot~|n| points 5673to knot~0, and the control points $z_0^-$ and $z_n^+$ are not used. 5674 5675@d left_type(#) == mem[#].hh.b0 {characterizes the path entering this knot} 5676@d right_type(#) == mem[#].hh.b1 {characterizes the path leaving this knot} 5677@d endpoint=0 {|left_type| at path beginning and |right_type| at path end} 5678@d x_coord(#) == mem[#+1].sc {the |x| coordinate of this knot} 5679@d y_coord(#) == mem[#+2].sc {the |y| coordinate of this knot} 5680@d left_x(#) == mem[#+3].sc {the |x| coordinate of previous control point} 5681@d left_y(#) == mem[#+4].sc {the |y| coordinate of previous control point} 5682@d right_x(#) == mem[#+5].sc {the |x| coordinate of next control point} 5683@d right_y(#) == mem[#+6].sc {the |y| coordinate of next control point} 5684@d knot_node_size=7 {number of words in a knot node} 5685 5686@ Before the B\'ezier control points have been calculated, the memory 5687space they will ultimately occupy is taken up by information that can be 5688used to compute them. There are four cases: 5689 5690\yskip 5691\textindent{$\bullet$} If |right_type=open|, the curve should leave 5692the knot in the same direction it entered; \MF\ will figure out a 5693suitable direction. 5694 5695\yskip 5696\textindent{$\bullet$} If |right_type=curl|, the curve should leave the 5697knot in a direction depending on the angle at which it enters the next 5698knot and on the curl parameter stored in |right_curl|. 5699 5700\yskip 5701\textindent{$\bullet$} If |right_type=given|, the curve should leave the 5702knot in a nonzero direction stored as an |angle| in |right_given|. 5703 5704\yskip 5705\textindent{$\bullet$} If |right_type=explicit|, the B\'ezier control 5706point for leaving this knot has already been computed; it is in the 5707|right_x| and |right_y| fields. 5708 5709\yskip\noindent 5710The rules for |left_type| are similar, but they refer to the curve entering 5711the knot, and to \\{left} fields instead of \\{right} fields. 5712 5713Non-|explicit| control points will be chosen based on ``tension'' parameters 5714in the |left_tension| and |right_tension| fields. The 5715`\&{atleast}' option is represented by negative tension values. 5716@:at_least_}{\&{atleast} primitive@> 5717 5718For example, the \MF\ path specification 5719$$\.{z0..z1..tension atleast 1..\{curl 2\}z2..z3\{-1,-2\}..tension 5720 3 and 4..p},$$ 5721where \.p is the path `\.{z4..controls z45 and z54..z5}', will be represented 5722by the six knots 5723\def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}} 5724$$\vbox{\halign{#\hfil&&\qquad#\hfil\cr 5725|left_type|&\\{left} info&|x_coord,y_coord|&|right_type|&\\{right} info\cr 5726\noalign{\yskip} 5727|endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr 5728|open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr 5729|curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr 5730|given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr 5731|open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr 5732|explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$ 5733Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|. 5734Of course, this example is more complicated than anything a normal user 5735would ever write. 5736 5737These types must satisfy certain restrictions because of the form of \MF's 5738path syntax: 5739(i)~|open| type never appears in the same node together with |endpoint|, 5740|given|, or |curl|. 5741(ii)~The |right_type| of a node is |explicit| if and only if the 5742|left_type| of the following node is |explicit|. 5743(iii)~|endpoint| types occur only at the ends, as mentioned above. 5744 5745@d left_curl==left_x {curl information when entering this knot} 5746@d left_given==left_x {given direction when entering this knot} 5747@d left_tension==left_y {tension information when entering this knot} 5748@d right_curl==right_x {curl information when leaving this knot} 5749@d right_given==right_x {given direction when leaving this knot} 5750@d right_tension==right_y {tension information when leaving this knot} 5751@d explicit=1 {|left_type| or |right_type| when control points are known} 5752@d given=2 {|left_type| or |right_type| when a direction is given} 5753@d curl=3 {|left_type| or |right_type| when a curl is desired} 5754@d open=4 {|left_type| or |right_type| when \MF\ should choose the direction} 5755 5756@ Here is a diagnostic routine that prints a given knot list 5757in symbolic form. It illustrates the conventions discussed above, 5758and checks for anomalies that might arise while \MF\ is being debugged. 5759 5760@<Declare subroutines for printing expressions@>= 5761procedure print_path(@!h:pointer;@!s:str_number;@!nuline:boolean); 5762label done,done1; 5763var @!p,@!q:pointer; {for list traversal} 5764begin print_diagnostic("Path",s,nuline); print_ln; 5765@.Path at line...@> 5766p:=h; 5767repeat q:=link(p); 5768if (p=null)or(q=null) then 5769 begin print_nl("???"); goto done; {this won't happen} 5770@.???@> 5771 end; 5772@<Print information for adjacent knots |p| and |q|@>; 5773p:=q; 5774if (p<>h)or(left_type(h)<>endpoint) then 5775 @<Print two dots, followed by |given| or |curl| if present@>; 5776until p=h; 5777if left_type(h)<>endpoint then print("cycle"); 5778done:end_diagnostic(true); 5779end; 5780 5781@ @<Print information for adjacent knots...@>= 5782print_two(x_coord(p),y_coord(p)); 5783case right_type(p) of 5784endpoint: begin if left_type(p)=open then print("{open?}"); {can't happen} 5785@.open?@> 5786 if (left_type(q)<>endpoint)or(q<>h) then q:=null; {force an error} 5787 goto done1; 5788 end; 5789explicit: @<Print control points between |p| and |q|, then |goto done1|@>; 5790open: @<Print information for a curve that begins |open|@>; 5791curl,given: @<Print information for a curve that begins |curl| or |given|@>; 5792othercases print("???") {can't happen} 5793@.???@> 5794endcases;@/ 5795if left_type(q)<=explicit then print("..control?") {can't happen} 5796@.control?@> 5797else if (right_tension(p)<>unity)or(left_tension(q)<>unity) then 5798 @<Print tension between |p| and |q|@>; 5799done1: 5800 5801@ Since |n_sin_cos| produces |fraction| results, which we will print as if they 5802were |scaled|, the magnitude of a |given| direction vector will be~4096. 5803 5804@<Print two dots...@>= 5805begin print_nl(" .."); 5806if left_type(p)=given then 5807 begin n_sin_cos(left_given(p)); print_char("{"); 5808 print_scaled(n_cos); print_char(","); 5809 print_scaled(n_sin); print_char("}"); 5810 end 5811else if left_type(p)=curl then 5812 begin print("{curl "); print_scaled(left_curl(p)); print_char("}"); 5813 end; 5814end 5815 5816@ @<Print tension between |p| and |q|@>= 5817begin print("..tension "); 5818if right_tension(p)<0 then print("atleast"); 5819print_scaled(abs(right_tension(p))); 5820if right_tension(p)<>left_tension(q) then 5821 begin print(" and "); 5822 if left_tension(q)<0 then print("atleast"); 5823 print_scaled(abs(left_tension(q))); 5824 end; 5825end 5826 5827@ @<Print control points between |p| and |q|, then |goto done1|@>= 5828begin print("..controls "); print_two(right_x(p),right_y(p)); print(" and "); 5829if left_type(q)<>explicit then print("??") {can't happen} 5830@.??@> 5831else print_two(left_x(q),left_y(q)); 5832goto done1; 5833end 5834 5835@ @<Print information for a curve that begins |open|@>= 5836if (left_type(p)<>explicit)and(left_type(p)<>open) then 5837 print("{open?}") {can't happen} 5838@.open?@> 5839 5840@ A curl of 1 is shown explicitly, so that the user sees clearly that 5841\MF's default curl is present. 5842 5843@<Print information for a curve that begins |curl|...@>= 5844begin if left_type(p)=open then print("??"); {can't happen} 5845@.??@> 5846if right_type(p)=curl then 5847 begin print("{curl "); print_scaled(right_curl(p)); 5848 end 5849else begin n_sin_cos(right_given(p)); print_char("{"); 5850 print_scaled(n_cos); print_char(","); print_scaled(n_sin); 5851 end; 5852print_char("}"); 5853end 5854 5855@ If we want to duplicate a knot node, we can say |copy_knot|: 5856 5857@p function copy_knot(@!p:pointer):pointer; 5858var @!q:pointer; {the copy} 5859@!k:0..knot_node_size-1; {runs through the words of a knot node} 5860begin q:=get_node(knot_node_size); 5861for k:=0 to knot_node_size-1 do mem[q+k]:=mem[p+k]; 5862copy_knot:=q; 5863end; 5864 5865@ The |copy_path| routine makes a clone of a given path. 5866 5867@p function copy_path(@!p:pointer):pointer; 5868label exit; 5869var @!q,@!pp,@!qq:pointer; {for list manipulation} 5870begin q:=get_node(knot_node_size); {this will correspond to |p|} 5871qq:=q; pp:=p; 5872loop@+ begin left_type(qq):=left_type(pp); 5873 right_type(qq):=right_type(pp);@/ 5874 x_coord(qq):=x_coord(pp); y_coord(qq):=y_coord(pp);@/ 5875 left_x(qq):=left_x(pp); left_y(qq):=left_y(pp);@/ 5876 right_x(qq):=right_x(pp); right_y(qq):=right_y(pp);@/ 5877 if link(pp)=p then 5878 begin link(qq):=q; copy_path:=q; return; 5879 end; 5880 link(qq):=get_node(knot_node_size); qq:=link(qq); pp:=link(pp); 5881 end; 5882exit:end; 5883 5884@ Similarly, there's a way to copy the {\sl reverse\/} of a path. This procedure 5885returns a pointer to the first node of the copy, if the path is a cycle, 5886but to the final node of a non-cyclic copy. The global 5887variable |path_tail| will point to the final node of the original path; 5888this trick makes it easier to implement `\&{doublepath}'. 5889 5890All node types are assumed to be |endpoint| or |explicit| only. 5891 5892@p function htap_ypoc(@!p:pointer):pointer; 5893label exit; 5894var @!q,@!pp,@!qq,@!rr:pointer; {for list manipulation} 5895begin q:=get_node(knot_node_size); {this will correspond to |p|} 5896qq:=q; pp:=p; 5897loop@+ begin right_type(qq):=left_type(pp); left_type(qq):=right_type(pp);@/ 5898 x_coord(qq):=x_coord(pp); y_coord(qq):=y_coord(pp);@/ 5899 right_x(qq):=left_x(pp); right_y(qq):=left_y(pp);@/ 5900 left_x(qq):=right_x(pp); left_y(qq):=right_y(pp);@/ 5901 if link(pp)=p then 5902 begin link(q):=qq; path_tail:=pp; htap_ypoc:=q; return; 5903 end; 5904 rr:=get_node(knot_node_size); link(rr):=qq; qq:=rr; pp:=link(pp); 5905 end; 5906exit:end; 5907 5908@ @<Glob...@>= 5909@!path_tail:pointer; {the node that links to the beginning of a path} 5910 5911@ When a cyclic list of knot nodes is no longer needed, it can be recycled by 5912calling the following subroutine. 5913 5914@<Declare the recycling subroutines@>= 5915procedure toss_knot_list(@!p:pointer); 5916var @!q:pointer; {the node being freed} 5917@!r:pointer; {the next node} 5918begin q:=p; 5919repeat r:=link(q); free_node(q,knot_node_size); q:=r; 5920until q=p; 5921end; 5922 5923@* \[18] Choosing control points. 5924Now we must actually delve into one of \MF's more difficult routines, 5925the |make_choices| procedure that chooses angles and control points for 5926the splines of a curve when the user has not specified them explicitly. 5927The parameter to |make_choices| points to a list of knots and 5928path information, as described above. 5929 5930A path decomposes into independent segments at ``breakpoint'' knots, 5931which are knots whose left and right angles are both prespecified in 5932some way (i.e., their |left_type| and |right_type| aren't both open). 5933 5934@p @t\4@>@<Declare the procedure called |solve_choices|@>@; 5935procedure make_choices(@!knots:pointer); 5936label done; 5937var @!h:pointer; {the first breakpoint} 5938@!p,@!q:pointer; {consecutive breakpoints being processed} 5939@<Other local variables for |make_choices|@>@; 5940begin check_arith; {make sure that |arith_error=false|} 5941if internal[tracing_choices]>0 then 5942 print_path(knots,", before choices",true); 5943@<If consecutive knots are equal, join them explicitly@>; 5944@<Find the first breakpoint, |h|, on the path; 5945 insert an artificial breakpoint if the path is an unbroken cycle@>; 5946p:=h; 5947repeat @<Fill in the control points between |p| and the next breakpoint, 5948 then advance |p| to that breakpoint@>; 5949until p=h; 5950if internal[tracing_choices]>0 then 5951 print_path(knots,", after choices",true); 5952if arith_error then @<Report an unexpected problem during the choice-making@>; 5953end; 5954 5955@ @<Report an unexpected problem during the choice...@>= 5956begin print_err("Some number got too big"); 5957@.Some number got too big@> 5958help2("The path that I just computed is out of range.")@/ 5959 ("So it will probably look funny. Proceed, for a laugh."); 5960put_get_error; arith_error:=false; 5961end 5962 5963@ Two knots in a row with the same coordinates will always be joined 5964by an explicit ``curve'' whose control points are identical with the 5965knots. 5966 5967@<If consecutive knots are equal, join them explicitly@>= 5968p:=knots; 5969repeat q:=link(p); 5970if x_coord(p)=x_coord(q) then if y_coord(p)=y_coord(q) then 5971 if right_type(p)>explicit then 5972 begin right_type(p):=explicit; 5973 if left_type(p)=open then 5974 begin left_type(p):=curl; left_curl(p):=unity; 5975 end; 5976 left_type(q):=explicit; 5977 if right_type(q)=open then 5978 begin right_type(q):=curl; right_curl(q):=unity; 5979 end; 5980 right_x(p):=x_coord(p); left_x(q):=x_coord(p);@/ 5981 right_y(p):=y_coord(p); left_y(q):=y_coord(p); 5982 end; 5983p:=q; 5984until p=knots 5985 5986@ If there are no breakpoints, it is necessary to compute the direction 5987angles around an entire cycle. In this case the |left_type| of the first 5988node is temporarily changed to |end_cycle|. 5989 5990@d end_cycle=open+1 5991 5992@<Find the first breakpoint, |h|, on the path...@>= 5993h:=knots; 5994loop@+ begin if left_type(h)<>open then goto done; 5995 if right_type(h)<>open then goto done; 5996 h:=link(h); 5997 if h=knots then 5998 begin left_type(h):=end_cycle; goto done; 5999 end; 6000 end; 6001done: 6002 6003@ If |right_type(p)<given| and |q=link(p)|, we must have 6004|right_type(p)=left_type(q)=explicit| or |endpoint|. 6005 6006@<Fill in the control points between |p| and the next breakpoint...@>= 6007q:=link(p); 6008if right_type(p)>=given then 6009 begin while (left_type(q)=open)and(right_type(q)=open) do q:=link(q); 6010 @<Fill in the control information between 6011 consecutive breakpoints |p| and |q|@>; 6012 end; 6013p:=q 6014 6015@ Before we can go further into the way choices are made, we need to 6016consider the underlying theory. The basic ideas implemented in |make_choices| 6017are due to John Hobby, who introduced the notion of ``mock curvature'' 6018@^Hobby, John Douglas@> 6019at a knot. Angles are chosen so that they preserve mock curvature when 6020a knot is passed, and this has been found to produce excellent results. 6021 6022It is convenient to introduce some notations that simplify the necessary 6023formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance 6024between knots |k| and |k+1|; and let 6025$${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$ 6026so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left 6027through an angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$. 6028The control points for the spline from $z_k$ to $z\k$ will be denoted by 6029$$\eqalign{z_k^+&=z_k+ 6030 \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr 6031 z\k^-&=z\k- 6032 \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$ 6033where $\rho_k$ and $\sigma\k$ are nonnegative ``velocity ratios'' at the 6034beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the 6035corresponding ``offset angles.'' These angles satisfy the condition 6036$$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$ 6037whenever the curve leaves an intermediate knot~|k| in the direction that 6038it enters. 6039 6040@ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the ``tension'' of 6041the curve at its beginning and ending points. This means that 6042$\rho_k=\alpha_k f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$, 6043where $f(\theta,\phi)$ is \MF's standard velocity function defined in 6044the |velocity| subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+, 6045z\k^-,z\k^{\phantom+};t)$ 6046has curvature 6047@^curvature@> 6048$${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}} 6049\qquad{\rm and}\qquad 6050{2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$ 6051at |t=0| and |t=1|, respectively. The mock curvature is the linear 6052@^mock curvature@> 6053approximation to this true curvature that arises in the limit for 6054small $\theta_k$ and~$\phi\k$, if second-order terms are discarded. 6055The standard velocity function satisfies 6056$$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$ 6057hence the mock curvatures are respectively 6058$${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}} 6059\qquad{\rm and}\qquad 6060{2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$ 6061 6062@ The turning angles $\psi_k$ are given, and equation $(*)$ above 6063determines $\phi_k$ when $\theta_k$ is known, so the task of 6064angle selection is essentially to choose appropriate values for each 6065$\theta_k$. When equation~$(*)$ is used to eliminate $\phi$~variables 6066from $(**)$, we obtain a system of linear equations of the form 6067$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$ 6068where 6069$$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}}, 6070\qquad B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}}, 6071\qquad C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}}, 6072\qquad D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$ 6073The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$ 6074will be at most $4\over3$. It follows that $B_k\G{5\over4}A_k$ and 6075$C_k\G{5\over4}D_k$; hence the equations are diagonally dominant; 6076hence they have a unique solution. Moreover, in most cases the tensions 6077are equal to~1, so that $B_k=2A_k$ and $C_k=2D_k$. This makes the 6078solution numerically stable, and there is an exponential damping 6079effect: The data at knot $k\pm j$ affects the angle at knot~$k$ by 6080a factor of~$O(2^{-j})$. 6081 6082@ However, we still must consider the angles at the starting and ending 6083knots of a non-cyclic path. These angles might be given explicitly, or 6084they might be specified implicitly in terms of an amount of ``curl.'' 6085 6086Let's assume that angles need to be determined for a non-cyclic path 6087starting at $z_0$ and ending at~$z_n$. Then equations of the form 6088$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$ 6089have been given for $0<k<n$, and it will be convenient to introduce 6090equations of the same form for $k=0$ and $k=n$, where 6091$$A_0=B_0=C_n=D_n=0.$$ 6092If $\theta_0$ is supposed to have a given value $E_0$, we simply 6093define $C_0=1$, $D_0=0$, and $R_0=E_0$. Otherwise a curl 6094parameter, $\gamma_0$, has been specified at~$z_0$; this means 6095that the mock curvature at $z_0$ should be $\gamma_0$ times the 6096mock curvature at $z_1$; i.e., 6097$${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}} 6098=\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$ 6099This equation simplifies to 6100$$(\alpha_0\chi_0+3-\beta_1)\theta_0+ 6101 \bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1= 6102 -\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$ 6103where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0= 6104\chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$. 6105It can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$, 6106hence the linear equations remain nonsingular. 6107 6108Similar considerations apply at the right end, when the final angle $\phi_n$ 6109may or may not need to be determined. It is convenient to let $\psi_n=0$, 6110hence $\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$, 6111or we have 6112$$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+ 6113(\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad 6114 \chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$ 6115 6116When |make_choices| chooses angles, it must compute the coefficients of 6117these linear equations, then solve the equations. To compute the coefficients, 6118it is necessary to compute arctangents of the given turning angles~$\psi_k$. 6119When the equations are solved, the chosen directions $\theta_k$ are put 6120back into the form of control points by essentially computing sines and 6121cosines. 6122 6123@ OK, we are ready to make the hard choices of |make_choices|. 6124Most of the work is relegated to an auxiliary procedure 6125called |solve_choices|, which has been introduced to keep 6126|make_choices| from being extremely long. 6127 6128@<Fill in the control information between...@>= 6129@<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$; 6130 set $n$ to the length of the path@>; 6131@<Remove |open| types at the breakpoints@>; 6132solve_choices(p,q,n) 6133 6134@ It's convenient to precompute quantities that will be needed several 6135times later. The values of |delta_x[k]| and |delta_y[k]| will be the 6136coordinates of $z\k-z_k$, and the magnitude of this vector will be 6137|delta[k]=@t$d_{k,k+1}$@>|. The path angle $\psi_k$ between $z_k-z_{k-1}$ 6138and $z\k-z_k$ will be stored in |psi[k]|. 6139 6140@<Glob...@>= 6141@!delta_x,@!delta_y,@!delta:array[0..path_size] of scaled; {knot differences} 6142@!psi:array[1..path_size] of angle; {turning angles} 6143 6144@ @<Other local variables for |make_choices|@>= 6145@!k,@!n:0..path_size; {current and final knot numbers} 6146@!s,@!t:pointer; {registers for list traversal} 6147@!delx,@!dely:scaled; {directions where |open| meets |explicit|} 6148@!sine,@!cosine:fraction; {trig functions of various angles} 6149 6150@ @<Calculate the turning angles...@>= 6151k:=0; s:=p; n:=path_size; 6152repeat t:=link(s); 6153delta_x[k]:=x_coord(t)-x_coord(s); 6154delta_y[k]:=y_coord(t)-y_coord(s); 6155delta[k]:=pyth_add(delta_x[k],delta_y[k]); 6156if k>0 then 6157 begin sine:=make_fraction(delta_y[k-1],delta[k-1]); 6158 cosine:=make_fraction(delta_x[k-1],delta[k-1]); 6159 psi[k]:=n_arg(take_fraction(delta_x[k],cosine)+ 6160 take_fraction(delta_y[k],sine), 6161 take_fraction(delta_y[k],cosine)- 6162 take_fraction(delta_x[k],sine)); 6163 end; 6164@:METAFONT capacity exceeded path size}{\quad path size@> 6165incr(k); s:=t; 6166if k=path_size then overflow("path size",path_size); 6167if s=q then n:=k; 6168until (k>=n)and(left_type(s)<>end_cycle); 6169if k=n then psi[n]:=0@+else psi[k]:=psi[1] 6170 6171@ When we get to this point of the code, |right_type(p)| is either 6172|given| or |curl| or |open|. If it is |open|, we must have 6173|left_type(p)=end_cycle| or |left_type(p)=explicit|. In the latter 6174case, the |open| type is converted to |given|; however, if the 6175velocity coming into this knot is zero, the |open| type is 6176converted to a |curl|, since we don't know the incoming direction. 6177 6178Similarly, |left_type(q)| is either |given| or |curl| or |open| or 6179|end_cycle|. The |open| possibility is reduced either to |given| or to |curl|. 6180 6181@<Remove |open| types at the breakpoints@>= 6182if left_type(q)=open then 6183 begin delx:=right_x(q)-x_coord(q); dely:=right_y(q)-y_coord(q); 6184 if (delx=0)and(dely=0) then 6185 begin left_type(q):=curl; left_curl(q):=unity; 6186 end 6187 else begin left_type(q):=given; left_given(q):=n_arg(delx,dely); 6188 end; 6189 end; 6190if (right_type(p)=open)and(left_type(p)=explicit) then 6191 begin delx:=x_coord(p)-left_x(p); dely:=y_coord(p)-left_y(p); 6192 if (delx=0)and(dely=0) then 6193 begin right_type(p):=curl; right_curl(p):=unity; 6194 end 6195 else begin right_type(p):=given; right_given(p):=n_arg(delx,dely); 6196 end; 6197 end 6198 6199@ Linear equations need to be solved whenever |n>1|; and also when |n=1| 6200and exactly one of the breakpoints involves a curl. The simplest case occurs 6201when |n=1| and there is a curl at both breakpoints; then we simply draw 6202a straight line. 6203 6204But before coding up the simple cases, we might as well face the general case, 6205since we must deal with it sooner or later, and since the general case 6206is likely to give some insight into the way simple cases can be handled best. 6207 6208When there is no cycle, the linear equations to be solved form a tri-diagonal 6209system, and we can apply the standard technique of Gaussian elimination 6210to convert that system to a sequence of equations of the form 6211$$\theta_0+u_0\theta_1=v_0,\quad 6212\theta_1+u_1\theta_2=v_1,\quad\ldots,\quad 6213\theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad 6214\theta_n=v_n.$$ 6215It is possible to do this diagonalization while generating the equations. 6216Once $\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots, 6217$\theta_1$, $\theta_0$; thus, the equations will be solved. 6218 6219The procedure is slightly more complex when there is a cycle, but the 6220basic idea will be nearly the same. In the cyclic case the right-hand 6221sides will be $v_k+w_k\theta_0$ instead of simply $v_k$, and we will start 6222the process off with $u_0=v_0=0$, $w_0=1$. The final equation will be not 6223$\theta_n=v_n$ but $\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate 6224ending routine will take account of the fact that $\theta_n=\theta_0$ and 6225eliminate the $w$'s from the system, after which the solution can be 6226obtained as before. 6227 6228When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer 6229variables |r|, |s|,~|t| will point respectively to knots |k-1|, |k|, 6230and~|k+1|. The $u$'s and $w$'s are scaled by $2^{28}$, i.e., they are 6231of type |fraction|; the $\theta$'s and $v$'s are of type |angle|. 6232 6233@<Glob...@>= 6234@!theta:array[0..path_size] of angle; {values of $\theta_k$} 6235@!uu:array[0..path_size] of fraction; {values of $u_k$} 6236@!vv:array[0..path_size] of angle; {values of $v_k$} 6237@!ww:array[0..path_size] of fraction; {values of $w_k$} 6238 6239@ Our immediate problem is to get the ball rolling by setting up the 6240first equation or by realizing that no equations are needed, and to fit 6241this initialization into a framework suitable for the overall computation. 6242 6243@<Declare the procedure called |solve_choices|@>= 6244@t\4@>@<Declare subroutines needed by |solve_choices|@>@; 6245procedure solve_choices(@!p,@!q:pointer;@!n:halfword); 6246label found,exit; 6247var @!k:0..path_size; {current knot number} 6248@!r,@!s,@!t:pointer; {registers for list traversal} 6249@<Other local variables for |solve_choices|@>@; 6250begin k:=0; s:=p; 6251loop@+ begin t:=link(s); 6252 if k=0 then @<Get the linear equations started; or |return| 6253 with the control points in place, if linear equations 6254 needn't be solved@> 6255 else case left_type(s) of 6256 end_cycle,open:@<Set up equation to match mock curvatures 6257 at $z_k$; then |goto found| with $\theta_n$ 6258 adjusted to equal $\theta_0$, if a cycle has ended@>; 6259 curl:@<Set up equation for a curl at $\theta_n$ 6260 and |goto found|@>; 6261 given:@<Calculate the given value of $\theta_n$ 6262 and |goto found|@>; 6263 end; {there are no other cases} 6264 r:=s; s:=t; incr(k); 6265 end; 6266found:@<Finish choosing angles and assigning control points@>; 6267exit:end; 6268 6269@ On the first time through the loop, we have |k=0| and |r| is not yet 6270defined. The first linear equation, if any, will have $A_0=B_0=0$. 6271 6272@<Get the linear equations started...@>= 6273case right_type(s) of 6274given: if left_type(t)=given then @<Reduce to simple case of two givens 6275 and |return|@> 6276 else @<Set up the equation for a given value of $\theta_0$@>; 6277curl: if left_type(t)=curl then @<Reduce to simple case of straight line 6278 and |return|@> 6279 else @<Set up the equation for a curl at $\theta_0$@>; 6280open: begin uu[0]:=0; vv[0]:=0; ww[0]:=fraction_one; 6281 end; {this begins a cycle} 6282end {there are no other cases} 6283 6284@ The general equation that specifies equality of mock curvature at $z_k$ is 6285$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$ 6286as derived above. We want to combine this with the already-derived equation 6287$\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain 6288a new equation 6289$\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the 6290equation 6291$$(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} 6292 -A_kw_{k-1}\theta_0$$ 6293by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with 6294fixed-point arithmetic, avoiding the chance of overflow while retaining 6295suitable precision. 6296 6297The calculations will be performed in several registers that 6298provide temporary storage for intermediate quantities. 6299 6300@<Other local variables for |solve_choices|@>= 6301@!aa,@!bb,@!cc,@!ff,@!acc:fraction; {temporary registers} 6302@!dd,@!ee:scaled; {likewise, but |scaled|} 6303@!lt,@!rt:scaled; {tension values} 6304 6305@ @<Set up equation to match mock curvatures...@>= 6306begin @<Calculate the values $\\{aa}=A_k/B_k$, $\\{bb}=D_k/C_k$, 6307 $\\{dd}=(3-\alpha_{k-1})d_{k,k+1}$, $\\{ee}=(3-\beta\k)d_{k-1,k}$, 6308 and $\\{cc}=(B_k-u_{k-1}A_k)/B_k$@>; 6309@<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>; 6310uu[k]:=take_fraction(ff,bb); 6311@<Calculate the values of $v_k$ and $w_k$@>; 6312if left_type(s)=end_cycle then 6313 @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>; 6314end 6315 6316@ Since tension values are never less than 3/4, the values |aa| and 6317|bb| computed here are never more than 4/5. 6318 6319@<Calculate the values $\\{aa}=...@>= 6320if abs(right_tension(r))=unity then 6321 begin aa:=fraction_half; dd:=2*delta[k]; 6322 end 6323else begin aa:=make_fraction(unity,3*abs(right_tension(r))-unity); 6324 dd:=take_fraction(delta[k], 6325 fraction_three-make_fraction(unity,abs(right_tension(r)))); 6326 end; 6327if abs(left_tension(t))=unity then 6328 begin bb:=fraction_half; ee:=2*delta[k-1]; 6329 end 6330else begin bb:=make_fraction(unity,3*abs(left_tension(t))-unity); 6331 ee:=take_fraction(delta[k-1], 6332 fraction_three-make_fraction(unity,abs(left_tension(t)))); 6333 end; 6334cc:=fraction_one-take_fraction(uu[k-1],aa) 6335 6336@ The ratio to be calculated in this step can be written in the form 6337$$\beta_k^2\cdot\\{ee}\over\beta_k^2\cdot\\{ee}+\alpha_k^2\cdot 6338 \\{cc}\cdot\\{dd},$$ 6339because of the quantities just calculated. The values of |dd| and |ee| 6340will not be needed after this step has been performed. 6341 6342@<Calculate the ratio $\\{ff}=C_k/(C_k+B_k-u_{k-1}A_k)$@>= 6343dd:=take_fraction(dd,cc); lt:=abs(left_tension(s)); rt:=abs(right_tension(s)); 6344if lt<>rt then {$\beta_k^{-1}\ne\alpha_k^{-1}$} 6345 if lt<rt then 6346 begin ff:=make_fraction(lt,rt); 6347 ff:=take_fraction(ff,ff); {$\alpha_k^2/\beta_k^2$} 6348 dd:=take_fraction(dd,ff); 6349 end 6350 else begin ff:=make_fraction(rt,lt); 6351 ff:=take_fraction(ff,ff); {$\beta_k^2/\alpha_k^2$} 6352 ee:=take_fraction(ee,ff); 6353 end; 6354ff:=make_fraction(ee,ee+dd) 6355 6356@ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous 6357equation was specified by a curl. In that case we must use a special 6358method of computation to prevent overflow. 6359 6360Fortunately, the calculations turn out to be even simpler in this ``hard'' 6361case. The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence 6362$-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-\\{cc}\cdot B_1\psi_1$. 6363 6364@<Calculate the values of $v_k$ and $w_k$@>= 6365acc:=-take_fraction(psi[k+1],uu[k]); 6366if right_type(r)=curl then 6367 begin ww[k]:=0; 6368 vv[k]:=acc-take_fraction(psi[1],fraction_one-ff); 6369 end 6370else begin ff:=make_fraction(fraction_one-ff,cc); {this is 6371 $B_k/(C_k+B_k-u_{k-1}A_k)<5$} 6372 acc:=acc-take_fraction(psi[k],ff); 6373 ff:=take_fraction(ff,aa); {this is $A_k/(C_k+B_k-u_{k-1}A_k)$} 6374 vv[k]:=acc-take_fraction(vv[k-1],ff); 6375 if ww[k-1]=0 then ww[k]:=0 6376 else ww[k]:=-take_fraction(ww[k-1],ff); 6377 end 6378 6379@ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k= 6380v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of 6381$\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$ 6382for |0<=k<n|, so that the cyclic case can be finished up just as if there 6383were no cycle. 6384 6385The idea in the following code is to observe that 6386$$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr 6387&=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots 6388 -u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0)\ldots{})\bigr),\cr}$$ 6389so we can solve for $\theta_n=\theta_0$. 6390 6391@<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>= 6392begin aa:=0; bb:=fraction_one; {we have |k=n|} 6393repeat decr(k); 6394if k=0 then k:=n; 6395aa:=vv[k]-take_fraction(aa,uu[k]); 6396bb:=ww[k]-take_fraction(bb,uu[k]); 6397until k=n; {now $\theta_n=\\{aa}+\\{bb}\cdot\theta_n$} 6398aa:=make_fraction(aa,fraction_one-bb); 6399theta[n]:=aa; vv[0]:=aa; 6400for k:=1 to n-1 do vv[k]:=vv[k]+take_fraction(aa,ww[k]); 6401goto found; 6402end 6403 6404@ @d reduce_angle(#)==if abs(#)>one_eighty_deg then 6405 if #>0 then #:=#-three_sixty_deg@+else #:=#+three_sixty_deg 6406 6407@<Calculate the given value of $\theta_n$...@>= 6408begin theta[n]:=left_given(s)-n_arg(delta_x[n-1],delta_y[n-1]); 6409reduce_angle(theta[n]); 6410goto found; 6411end 6412 6413@ @<Set up the equation for a given value of $\theta_0$@>= 6414begin vv[0]:=right_given(s)-n_arg(delta_x[0],delta_y[0]); 6415reduce_angle(vv[0]); 6416uu[0]:=0; ww[0]:=0; 6417end 6418 6419@ @<Set up the equation for a curl at $\theta_0$@>= 6420begin cc:=right_curl(s); lt:=abs(left_tension(t)); rt:=abs(right_tension(s)); 6421if (rt=unity)and(lt=unity) then 6422 uu[0]:=make_fraction(cc+cc+unity,cc+two) 6423else uu[0]:=curl_ratio(cc,rt,lt); 6424vv[0]:=-take_fraction(psi[1],uu[0]); ww[0]:=0; 6425end 6426 6427@ @<Set up equation for a curl at $\theta_n$...@>= 6428begin cc:=left_curl(s); lt:=abs(left_tension(s)); rt:=abs(right_tension(r)); 6429if (rt=unity)and(lt=unity) then 6430 ff:=make_fraction(cc+cc+unity,cc+two) 6431else ff:=curl_ratio(cc,lt,rt); 6432theta[n]:=-make_fraction(take_fraction(vv[n-1],ff), 6433 fraction_one-take_fraction(ff,uu[n-1])); 6434goto found; 6435end 6436 6437@ The |curl_ratio| subroutine has three arguments, which our previous notation 6438encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is 6439a somewhat tedious program to calculate 6440$${(3-\alpha)\alpha^2\gamma+\beta^3\over 6441 \alpha^3\gamma+(3-\beta)\beta^2},$$ 6442with the result reduced to 4 if it exceeds 4. (This reduction of curl 6443is necessary only if the curl and tension are both large.) 6444The values of $\alpha$ and $\beta$ will be at most~4/3. 6445 6446@<Declare subroutines needed by |solve_choices|@>= 6447function curl_ratio(@!gamma,@!a_tension,@!b_tension:scaled):fraction; 6448var @!alpha,@!beta,@!num,@!denom,@!ff:fraction; {registers} 6449begin alpha:=make_fraction(unity,a_tension); 6450beta:=make_fraction(unity,b_tension);@/ 6451if alpha<=beta then 6452 begin ff:=make_fraction(alpha,beta); ff:=take_fraction(ff,ff); 6453 gamma:=take_fraction(gamma,ff);@/ 6454 beta:=beta div @'10000; {convert |fraction| to |scaled|} 6455 denom:=take_fraction(gamma,alpha)+three-beta; 6456 num:=take_fraction(gamma,fraction_three-alpha)+beta; 6457 end 6458else begin ff:=make_fraction(beta,alpha); ff:=take_fraction(ff,ff); 6459 beta:=take_fraction(beta,ff) div @'10000; {convert |fraction| to |scaled|} 6460 denom:=take_fraction(gamma,alpha)+(ff div 1365)-beta; 6461 {$1365\approx 2^{12}/3$} 6462 num:=take_fraction(gamma,fraction_three-alpha)+beta; 6463 end; 6464if num>=denom+denom+denom+denom then curl_ratio:=fraction_four 6465else curl_ratio:=make_fraction(num,denom); 6466end; 6467 6468@ We're in the home stretch now. 6469 6470@<Finish choosing angles and assigning control points@>= 6471for k:=n-1 downto 0 do theta[k]:=vv[k]-take_fraction(theta[k+1],uu[k]); 6472s:=p; k:=0; 6473repeat t:=link(s);@/ 6474n_sin_cos(theta[k]); st:=n_sin; ct:=n_cos;@/ 6475n_sin_cos(-psi[k+1]-theta[k+1]); sf:=n_sin; cf:=n_cos;@/ 6476set_controls(s,t,k);@/ 6477incr(k); s:=t; 6478until k=n 6479 6480@ The |set_controls| routine actually puts the control points into 6481a pair of consecutive nodes |p| and~|q|. Global variables are used to 6482record the values of $\sin\theta$, $\cos\theta$, $\sin\phi$, and 6483$\cos\phi$ needed in this calculation. 6484 6485@<Glob...@>= 6486@!st,@!ct,@!sf,@!cf:fraction; {sines and cosines} 6487 6488@ @<Declare subroutines needed by |solve_choices|@>= 6489procedure set_controls(@!p,@!q:pointer;@!k:integer); 6490var @!rr,@!ss:fraction; {velocities, divided by thrice the tension} 6491@!lt,@!rt:scaled; {tensions} 6492@!sine:fraction; {$\sin(\theta+\phi)$} 6493begin lt:=abs(left_tension(q)); rt:=abs(right_tension(p)); 6494rr:=velocity(st,ct,sf,cf,rt); 6495ss:=velocity(sf,cf,st,ct,lt); 6496if (right_tension(p)<0)or(left_tension(q)<0) then @<Decrease the velocities, 6497 if necessary, to stay inside the bounding triangle@>; 6498right_x(p):=x_coord(p)+take_fraction( 6499 take_fraction(delta_x[k],ct)-take_fraction(delta_y[k],st),rr); 6500right_y(p):=y_coord(p)+take_fraction( 6501 take_fraction(delta_y[k],ct)+take_fraction(delta_x[k],st),rr); 6502left_x(q):=x_coord(q)-take_fraction( 6503 take_fraction(delta_x[k],cf)+take_fraction(delta_y[k],sf),ss); 6504left_y(q):=y_coord(q)-take_fraction( 6505 take_fraction(delta_y[k],cf)-take_fraction(delta_x[k],sf),ss); 6506right_type(p):=explicit; left_type(q):=explicit; 6507end; 6508 6509@ The boundedness conditions $\\{rr}\L\sin\phi\,/\sin(\theta+\phi)$ and 6510$\\{ss}\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$, 6511$\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise 6512there is no ``bounding triangle.'' 6513 6514@<Decrease the velocities, if necessary...@>= 6515if((st>=0)and(sf>=0))or((st<=0)and(sf<=0)) then 6516 begin sine:=take_fraction(abs(st),cf)+take_fraction(abs(sf),ct); 6517 if sine>0 then 6518 begin sine:=take_fraction(sine,fraction_one+unity); {safety factor} 6519 if right_tension(p)<0 then 6520 if ab_vs_cd(abs(sf),fraction_one,rr,sine)<0 then 6521 rr:=make_fraction(abs(sf),sine); 6522 if left_tension(q)<0 then 6523 if ab_vs_cd(abs(st),fraction_one,ss,sine)<0 then 6524 ss:=make_fraction(abs(st),sine); 6525 end; 6526 end 6527 6528@ Only the simple cases remain to be handled. 6529 6530@<Reduce to simple case of two givens and |return|@>= 6531begin aa:=n_arg(delta_x[0],delta_y[0]);@/ 6532n_sin_cos(right_given(p)-aa); ct:=n_cos; st:=n_sin;@/ 6533n_sin_cos(left_given(q)-aa); cf:=n_cos; sf:=-n_sin;@/ 6534set_controls(p,q,0); return; 6535end 6536 6537@ @<Reduce to simple case of straight line and |return|@>= 6538begin right_type(p):=explicit; left_type(q):=explicit; 6539lt:=abs(left_tension(q)); rt:=abs(right_tension(p)); 6540if rt=unity then 6541 begin if delta_x[0]>=0 then right_x(p):=x_coord(p)+((delta_x[0]+1) div 3) 6542 else right_x(p):=x_coord(p)+((delta_x[0]-1) div 3); 6543 if delta_y[0]>=0 then right_y(p):=y_coord(p)+((delta_y[0]+1) div 3) 6544 else right_y(p):=y_coord(p)+((delta_y[0]-1) div 3); 6545 end 6546else begin ff:=make_fraction(unity,3*rt); {$\alpha/3$} 6547 right_x(p):=x_coord(p)+take_fraction(delta_x[0],ff); 6548 right_y(p):=y_coord(p)+take_fraction(delta_y[0],ff); 6549 end; 6550if lt=unity then 6551 begin if delta_x[0]>=0 then left_x(q):=x_coord(q)-((delta_x[0]+1) div 3) 6552 else left_x(q):=x_coord(q)-((delta_x[0]-1) div 3); 6553 if delta_y[0]>=0 then left_y(q):=y_coord(q)-((delta_y[0]+1) div 3) 6554 else left_y(q):=y_coord(q)-((delta_y[0]-1) div 3); 6555 end 6556else begin ff:=make_fraction(unity,3*lt); {$\beta/3$} 6557 left_x(q):=x_coord(q)-take_fraction(delta_x[0],ff); 6558 left_y(q):=y_coord(q)-take_fraction(delta_y[0],ff); 6559 end; 6560return; 6561end 6562 6563@* \[19] Generating discrete moves. 6564The purpose of the next part of \MF\ is to compute discrete approximations 6565to curves described as parametric polynomial functions $z(t)$. 6566We shall start with the low level first, because an efficient ``engine'' 6567is needed to support the high-level constructions. 6568 6569Most of the subroutines are based on variations of a single theme, 6570namely the idea of {\sl bisection}. Given a Bernshte{\u\i}n polynomial 6571@^Bernshte{\u\i}n, Serge{\u\i} Natanovich@> 6572$$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$ 6573we can conveniently bisect its range as follows: 6574 6575\smallskip 6576\textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|. 6577 6578\smallskip 6579\textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for 6580|0<=k<n-j|, for |0<=j<n|. 6581 6582\smallskip\noindent 6583Then 6584$$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t) 6585 =B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$ 6586This formula gives us the coefficients of polynomials to use over the ranges 6587$0\L t\L{1\over2}$ and ${1\over2}\L t\L1$. 6588 6589In our applications it will usually be possible to work indirectly with 6590numbers that allow us to deduce relevant properties of the polynomials 6591without actually computing the polynomial values. We will deal with 6592coefficients $Z_k=2^l(z_k-z_{k-1})$ for |1<=k<=n|, instead of 6593the actual numbers $z_0$, $z_1$, \dots,~$z_n$, and the value of~|l| will 6594increase by~1 at each bisection step. This technique reduces the 6595amount of calculation needed for bisection and also increases the 6596accuracy of evaluation (since one bit of precision is gained at each 6597bisection). Indeed, the bisection process now becomes one level shorter: 6598 6599\smallskip 6600\textindent{$1'$)} Let $Z_k^{(1)}=Z_k$, for |1<=k<=n|. 6601 6602\smallskip 6603\textindent{$2'$)} Let $Z_k^{(j+1)}={1\over2}(Z_k^{(j)}+Z\k^{(j)})$, for 6604|1<=k<=n-j|, for |1<=j<n|. 6605 6606\smallskip\noindent 6607The relevant coefficients $(Z'_1,\ldots,Z'_n)$ and $(Z''_1,\ldots,Z''_n)$ 6608for the two subintervals after bisection are respectively 6609$(Z_1^{(1)},Z_1^{(2)},\ldots,Z_1^{(n)})$ and 6610$(Z_1^{(n)},Z_2^{(n-1)},\ldots,Z_n^{(1)})$. 6611And the values of $z_0$ appropriate for the bisected interval are $z'_0=z_0$ 6612and $z''_0=z_0+(Z'_1+Z'_2+\cdots+Z'_n)/2^{l+1}$. 6613 6614Step $2'$ involves division by~2, which introduces computational errors 6615of at most $1\over2$ at each step; thus after $l$~levels of bisection the 6616integers $Z_k$ will differ from their true values by at most $(n-1)l/2$. 6617This error rate is quite acceptable, considering that we have $l$~more 6618bits of precision in the $Z$'s by comparison with the~$z$'s. Note also 6619that the $Z$'s remain bounded; there's no danger of integer overflow, even 6620though we have the identity $Z_k=2^l(z_k-z_{k-1})$ for arbitrarily large~$l$. 6621 6622In fact, we can show not only that the $Z$'s remain bounded, but also that 6623they become nearly equal, since they are control points for a polynomial 6624of one less degree. If $\vert Z\k-Z_k\vert\L M$ initially, it is possible 6625to prove that $\vert Z\k-Z_k\vert\L\lceil M/2^l\rceil$ after $l$~levels 6626of bisection, even in the presence of rounding errors. Here's the 6627proof [cf.~Lane and Riesenfeld, {\sl IEEE Trans.\ on Pattern Analysis 6628@^Lane, Jeffrey Michael@> 6629@^Riesenfeld, Richard Franklin@> 6630and Machine Intelligence\/ \bf PAMI-2} (1980), 35--46]: Assuming that 6631$\vert Z\k-Z_k\vert\L M$ before bisection, we want to prove that 6632$\vert Z\k-Z_k\vert\L\lceil M/2\rceil$ afterward. First we show that 6633$\vert Z\k^{(j)}-Z_k^{(j)}\vert\L M$ for all $j$ and~$k$, by induction 6634on~$j$; this follows from the fact that 6635$$\bigl\vert\\{half}(a+b)-\\{half}(b+c)\bigr\vert\L 6636 \max\bigl(\vert a-b\vert,\vert b-c\vert\bigr)$$ 6637holds for both of the rounding rules $\\{half}(x)=\lfloor x/2\rfloor$ 6638and $\\{half}(x)={\rm sign}(x)\lfloor\vert x/2\vert\rfloor$. 6639(If $\vert a-b\vert$ and $\vert b-c\vert$ are equal, then 6640$a+b$ and $b+c$ are both even or both odd. The rounding errors either 6641cancel or round the numbers toward each other; hence 6642$$\eqalign{\bigl\vert\\{half}(a+b)-\\{half}(b+c)\bigr\vert 6643&\L\textstyle\bigl\vert{1\over2}(a+b)-{1\over2}(b+c)\bigr\vert\cr 6644&=\textstyle\bigl\vert{1\over2}(a-b)+{1\over2}(b-c)\bigr\vert 6645\L\max\bigl(\vert a-b\vert,\vert b-c\vert\bigr),\cr}$$ 6646as required. A simpler argument applies if $\vert a-b\vert$ and 6647$\vert b-c\vert$ are unequal.) Now it is easy to see that 6648$\vert Z_1^{(j+1)}-Z_1^{(j)}\vert\L\bigl\lfloor{1\over2} 6649\vert Z_2^{(j)}-Z_1^{(j)}\vert+{1\over2}\bigr\rfloor 6650\L\bigl\lfloor{1\over2}(M+1)\bigr\rfloor=\lceil M/2\rceil$. 6651 6652Another interesting fact about bisection is the identity 6653$$Z_1'+\cdots+Z_n'+Z_1''+\cdots+Z_n''=2(Z_1+\cdots+Z_n+E),$$ 6654where $E$ is the sum of the rounding errors in all of the halving 6655operations ($\vert E\vert\L n(n-1)/4$). 6656 6657@ We will later reduce the problem of digitizing a complex cubic 6658$z(t)=B(z_0,z_1,z_2,z_3;t)$ to the following simpler problem: 6659Given two real cubics 6660$x(t)=B(x_0,x_1,x_2,x_3;t)$ 6661and $y(t)=B(y_0,y_1,y_2,y_3;t)$ that are monotone nondecreasing, 6662determine the set of integer points 6663$$P=\bigl\{\bigl(\lfloor x(t)\rfloor,\lfloor y(t)\rfloor\bigr) 6664\bigm\vert 0\L t\L 1\bigr\}.$$ 6665Well, the problem isn't actually quite so clean as this; when the path 6666goes very near an integer point $(a,b)$, computational errors may 6667make us think that $P$ contains $(a-1,b)$ while in reality it should 6668contain $(a,b-1)$. Furthermore, if the path goes {\sl exactly\/} 6669through the integer points $(a-1,b-1)$ and 6670$(a,b)$, we will want $P$ to contain one 6671of the two points $(a-1,b)$ or $(a,b-1)$, so that $P$ can be described 6672entirely by ``rook moves'' upwards or to the right; no diagonal 6673moves from $(a-1,b-1)$ to~$(a,b)$ will be allowed. 6674 6675Thus, the set $P$ we wish to compute will merely be an approximation 6676to the set described in the formula above. It will consist of 6677$\lfloor x(1)\rfloor-\lfloor x(0)\rfloor$ rightward moves and 6678$\lfloor y(1)\rfloor-\lfloor y(0)\rfloor$ upward moves, intermixed 6679in some order. Our job will be to figure out a suitable order. 6680 6681The following recursive strategy suggests itself, when we recall that 6682$x(0)=x_0$, $x(1)=x_3$, $y(0)=y_0$, and $y(1)=y_3$: 6683 6684\smallskip 6685If $\lfloor x_0\rfloor=\lfloor x_3\rfloor$ then take 6686$\lfloor y_3\rfloor-\lfloor y_0\rfloor$ steps up. 6687 6688Otherwise if $\lfloor y_0\rfloor=\lfloor y_3\rfloor$ then take 6689$\lfloor x_3\rfloor-\lfloor x_0\rfloor$ steps to the right. 6690 6691Otherwise bisect the current cubics and repeat the process on both halves. 6692 6693\yskip\noindent 6694This intuitively appealing formulation does not quite solve the problem, 6695because it may never terminate. For example, it's not hard to see that 6696no steps will {\sl ever\/} be taken if $(x_0,x_1,x_2,x_3)=(y_0,y_1,y_2,y_3)$! 6697However, we can surmount this difficulty with a bit of care; so let's 6698proceed to flesh out the algorithm as stated, before worrying about 6699such details. 6700 6701The bisect-and-double strategy discussed above suggests that we represent 6702$(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})$ 6703for some~$l$. Initially $l=16$, since the $x$'s are |scaled|. 6704In order to deal with other aspects of the algorithm we will want to 6705maintain also the quantities $m=\lfloor x_3\rfloor-\lfloor x_0\rfloor$ 6706and $R=2^l(x_0\bmod 1)$. Similarly, 6707$(y_0,y_1,y_2,y_3)$ will be represented by $(Y_1,Y_2,Y_3)$, 6708$n=\lfloor y_3\rfloor-\lfloor y_0\rfloor$, 6709and $S=2^l(y_0\bmod 1)$. The algorithm now takes the following form: 6710 6711\smallskip 6712If $m=0$ then take $n$ steps up. 6713 6714Otherwise if $n=0$ then take $m$ steps to the right. 6715 6716Otherwise bisect the current cubics and repeat the process on both halves. 6717 6718\smallskip\noindent 6719The bisection process for $(X_1,X_2,X_3,m,R,l)$ reduces, in essence, 6720to the following formulas: 6721$$\vbox{\halign{$#\hfil$\cr 6722X_2'=\\{half}(X_1+X_2),\quad 6723X_2''=\\{half}(X_2+X_3),\quad 6724X_3'=\\{half}(X_2'+X_2''),\cr 6725X_1'=X_1,\quad 6726X_1''=X_3',\quad 6727X_3''=X_3,\cr 6728R'=2R,\quad 6729T=X_1'+X_2'+X_3'+R',\quad 6730R''=T\bmod 2^{l+1},\cr 6731m'=\lfloor T/2^{l+1}\rfloor,\quad 6732m''=m-m'.\cr}}$$ 6733 6734@ When $m=n=1$, the computation can be speeded up because we simply 6735need to decide between two alternatives, (up,\thinspace right) 6736versus (right,\thinspace up). There appears to be no simple, direct 6737way to make the correct decision by looking at the values of 6738$(X_1,X_2,X_3,R)$ and 6739$(Y_1,Y_2,Y_3,S)$; but we can streamline the bisection process, and 6740we can use the fact that only one of the two descendants needs to 6741be examined after each bisection. Furthermore, we observed earlier 6742that after several levels of bisection the $X$'s and $Y$'s will be nearly 6743equal; so we will be justified in assuming that the curve is essentially a 6744straight line. (This, incidentally, solves the problem of infinite 6745recursion mentioned earlier.) 6746 6747It is possible to show that 6748$$m=\bigl\lfloor(X_1+X_2+X_3+R+E)\,/\,2^l\bigr\rfloor,$$ 6749where $E$ is an accumulated rounding error that is at most 6750$3\cdot(2^{l-16}-1)$ in absolute value. We will make sure that 6751the $X$'s are less than $2^{28}$; hence when $l=30$ we must 6752have |m<=1|. This proves that the special case $m=n=1$ is 6753bound to be reached by the time $l=30$. Furthermore $l=30$ is 6754a suitable time to make the straight line approximation, 6755if the recursion hasn't already died out, because the maximum 6756difference between $X$'s will then be $<2^{14}$; this corresponds 6757to an error of $<1$ with respect to the original scaling. 6758(Stating this another way, each bisection makes the curve two bits 6759closer to a straight line, hence 14 bisections are sufficient for 676028-bit accuracy.) 6761 6762In the case of a straight line, the curve goes first right, then up, 6763if and only if $(T-2^l)(2^l-S)>(U-2^l)(2^l-R)$, where 6764$T=X_1+X_2+X_3+R$ and $U=Y_1+Y_2+Y_3+S$. For the actual curve 6765essentially runs from $(R/2^l,S/2^l)$ to $(T/2^l,U/2^l)$, and 6766we are testing whether or not $(1,1)$ is above the straight 6767line connecting these two points. (This formula assumes that $(1,1)$ 6768is not exactly on the line.) 6769 6770@ We have glossed over the problem of tie-breaking in ambiguous 6771cases when the cubic curve passes exactly through integer points. 6772\MF\ finesses this problem by assuming that coordinates 6773$(x,y)$ actually stand for slightly perturbed values $(x+\xi,y+\eta)$, 6774where $\xi$ and~$\eta$ are infinitesimals whose signs will determine 6775what to do when $x$ and/or~$y$ are exact integers. The quantities 6776$\lfloor x\rfloor$ and~$\lfloor y\rfloor$ in the formulas above 6777should actually read $\lfloor x+\xi\rfloor$ and $\lfloor y+\eta\rfloor$. 6778 6779If $x$ is a |scaled| value, we have $\lfloor x+\xi\rfloor=\lfloor x\rfloor$ 6780if $\xi>0$, and $\lfloor x+\xi\rfloor=\lfloor x-2^{-16}\rfloor$ if 6781$\xi<0$. It is convenient to represent $\xi$ by the integer |xi_corr|, 6782defined to be 0~if $\xi>0$ and 1~if $\xi<0$; then, for example, the 6783integer $\lfloor x+\xi\rfloor$ can be computed as 6784|floor_unscaled(x-xi_corr)|. Similarly, $\eta$ is conveniently 6785represented by~|eta_corr|. 6786 6787In our applications the sign of $\xi-\eta$ will always be the same as 6788the sign of $\xi$. Therefore it turns out that the rule for straight 6789lines, as stated above, should be modified as follows in the case of 6790ties: The line goes first right, then up, if and only if 6791$(T-2^l)(2^l-S)+\xi>(U-2^l)(2^l-R)$. And this relation holds iff 6792$|ab_vs_cd|(T-2^l,2^l-S,U-2^l,2^l-R)-|xi_corr|\ge0$. 6793 6794These conventions for rounding are symmetrical, in the sense that the 6795digitized moves obtained from $(x_0,x_1,x_2,x_3,y_0,y_1,y_2,y_3,\xi,\eta)$ 6796will be exactly complementary to the moves that would be obtained from 6797$(-x_3,-x_2,-x_1,-x_0,-y_3,-y_2,-y_1,-y_0,-\xi,-\eta)$, if arithmetic 6798is exact. However, truncation errors in the bisection process might 6799upset the symmetry. We can restore much of the lost symmetry by adding 6800|xi_corr| or |eta_corr| when halving the data. 6801 6802@ One further possibility needs to be mentioned: The algorithm 6803will be applied only to cubic polynomials $B(x_0,x_1,x_2,x_3;t)$ that 6804are nondecreasing as $t$~varies from 0 to~1; this condition turns 6805out to hold if and only if $x_0\L x_1$ and $x_2\L x_3$, and either 6806$x_1\L x_2$ or $(x_1-x_2)^2\L(x_1-x_0)(x_3-x_2)$. If bisection were 6807carried out with perfect accuracy, these relations would remain 6808invariant. But rounding errors can creep in, hence the bisection 6809algorithm can produce non-monotonic subproblems from monotonic 6810initial conditions. This leads to the potential danger that $m$ or~$n$ 6811could become negative in the algorithm described above. 6812 6813For example, if we start with $(x_1-x_0,x_2-x_1,x_3-x_2)= 6814(X_1,X_2,X_3)=(7,-16,39)$, the corresponding polynomial is 6815monotonic, because $16^2<7\cdot39$. But the bisection algorithm 6816produces the left descendant $(7,-5,3)$, which is nonmonotonic; 6817its right descendant is~$(0,-1,3)$. 6818 6819\def\xt{{\tilde x}} 6820Fortunately we can prove that such rounding errors will never cause 6821the algorithm to make a tragic mistake. At every stage we are working 6822with numbers corresponding to a cubic polynomial $B(\xt_0, 6823\xt_1,\xt_2,\xt_3)$ that approximates some 6824monotonic polynomial $B(x_0,x_1,x_2,x_3)$. The accumulated errors are 6825controlled so that $\vert x_k-\xt_k\vert<\epsilon=3\cdot2^{-16}$. 6826If bisection is done at some stage of the recursion, we have 6827$m=\lfloor\xt_3\rfloor-\lfloor\xt_0\rfloor>0$, and the algorithm 6828computes a bisection value $\bar x$ such that $m'=\lfloor\bar x\rfloor- 6829\lfloor\xt_0\rfloor$ 6830and $m''=\lfloor\xt_3\rfloor-\lfloor\bar x\rfloor$. We want to prove 6831that neither $m'$ nor $m''$ can be negative. Since $\bar x$ is an 6832approximation to a value in the interval $[x_0,x_3]$, we have 6833$\bar x>x_0-\epsilon$ and $\bar x<x_3+\epsilon$, hence $\bar x> 6834\xt_0-2\epsilon$ and $\bar x<\xt_3+2\epsilon$. 6835If $m'$ is negative we must have $\xt_0\bmod 1<2\epsilon$; 6836if $m''$ is negative we must have $\xt_3\bmod 1>1-2\epsilon$. 6837In either case the condition $\lfloor\xt_3\rfloor-\lfloor\xt_0\rfloor>0$ 6838implies that $\xt_3-\xt_0>1-2\epsilon$, hence $x_3-x_0>1-4\epsilon$. 6839But it can be shown that if $B(x_0,x_1,x_2,x_3;t)$ is a monotonic 6840cubic, then $B(x_0,x_1,x_2,x_3;{1\over2})$ is always between 6841$.06[x_0,x_3]$ and $.94[x_0,x_3]$; and it is impossible for $\bar x$ 6842to be within~$\epsilon$ of such a number. Contradiction! 6843(The constant .06 is actually $(2-\sqrt3\,)/4$; the worst case 6844occurs for polynomials like $B(0,2-\sqrt3,1-\sqrt3,3;t)$.) 6845 6846@ OK, now that a long theoretical preamble has justified the 6847bisection-and-doubling algorithm, we are ready to proceed with 6848its actual coding. But we still haven't discussed the 6849form of the output. 6850 6851For reasons to be discussed later, we shall find it convenient to 6852record the output as follows: Moving one step up is represented by 6853appending a `1' to a list; moving one step right is represented by 6854adding unity to the element at the end of the list. Thus, for example, 6855the net effect of ``(up, right, right, up, right)'' is to append 6856$(3,2)$. 6857 6858The list is kept in a global array called |move|. Before starting the 6859algorithm, \MF\ should check that $\\{move\_ptr}+\lfloor y_3\rfloor 6860-\lfloor y_0\rfloor\L\\{move\_size}$, so that the list won't exceed 6861the bounds of this array. 6862 6863@<Glob...@>= 6864@!move:array[0..move_size] of integer; {the recorded moves} 6865@!move_ptr:0..move_size; {the number of items in the |move| list} 6866 6867@ When bisection occurs, we ``push'' the subproblem corresponding 6868to the right-hand subinterval onto the |bisect_stack| while 6869we continue to work on the left-hand subinterval. Thus, the |bisect_stack| 6870will hold $(X_1,X_2,X_3,R,m,Y_1,Y_2,Y_3,S,n,l)$ values for 6871subproblems yet to be tackled. 6872 6873At most 15 subproblems will be on the stack at once (namely, for 6874$l=15$,~16, \dots,~29); but the stack is bigger than this, because 6875it is used also for more complicated bisection algorithms. 6876 6877@d stack_x1==bisect_stack[bisect_ptr] {stacked value of $X_1$} 6878@d stack_x2==bisect_stack[bisect_ptr+1] {stacked value of $X_2$} 6879@d stack_x3==bisect_stack[bisect_ptr+2] {stacked value of $X_3$} 6880@d stack_r==bisect_stack[bisect_ptr+3] {stacked value of $R$} 6881@d stack_m==bisect_stack[bisect_ptr+4] {stacked value of $m$} 6882@d stack_y1==bisect_stack[bisect_ptr+5] {stacked value of $Y_1$} 6883@d stack_y2==bisect_stack[bisect_ptr+6] {stacked value of $Y_2$} 6884@d stack_y3==bisect_stack[bisect_ptr+7] {stacked value of $Y_3$} 6885@d stack_s==bisect_stack[bisect_ptr+8] {stacked value of $S$} 6886@d stack_n==bisect_stack[bisect_ptr+9] {stacked value of $n$} 6887@d stack_l==bisect_stack[bisect_ptr+10] {stacked value of $l$} 6888@d move_increment=11 {number of items pushed by |make_moves|} 6889 6890@<Glob...@>= 6891@!bisect_stack:array[0..bistack_size] of integer; 6892@!bisect_ptr:0..bistack_size; 6893 6894@ @<Check the ``constant'' values...@>= 6895if 15*move_increment>bistack_size then bad:=31; 6896 6897@ The |make_moves| subroutine is given |scaled| values $(x_0,x_1,x_2,x_3)$ 6898and $(y_0,y_1,y_2,y_3)$ that represent monotone-nondecreasing polynomials; 6899it makes $\lfloor x_3+\xi\rfloor-\lfloor x_0+\xi\rfloor$ rightward moves 6900and $\lfloor y_3+\eta\rfloor-\lfloor y_0+\eta\rfloor$ upward moves, as 6901explained earlier. (Here $\lfloor x+\xi\rfloor$ actually stands for 6902$\lfloor x/2^{16}-|xi_corr|\rfloor$, if $x$ is regarded as an integer 6903without scaling.) The unscaled integers $x_k$ and~$y_k$ should be less 6904than $2^{28}$ in magnitude. 6905 6906It is assumed that $|move_ptr| + \lfloor y_3+\eta\rfloor - 6907\lfloor y_0+\eta\rfloor < |move_size|$ when this procedure is called, 6908so that the capacity of the |move| array will not be exceeded. 6909 6910The variables |r| and |s| in this procedure stand respectively for 6911$R-|xi_corr|$ and $S-|eta_corr|$ in the theory discussed above. 6912 6913@p procedure make_moves(@!xx0,@!xx1,@!xx2,@!xx3,@!yy0,@!yy1,@!yy2,@!yy3: 6914 scaled;@!xi_corr,@!eta_corr:small_number); 6915label continue, done, exit; 6916var @!x1,@!x2,@!x3,@!m,@!r,@!y1,@!y2,@!y3,@!n,@!s,@!l:integer; 6917 {bisection variables explained above} 6918@!q,@!t,@!u,@!x2a,@!x3a,@!y2a,@!y3a:integer; {additional temporary registers} 6919begin if (xx3<xx0)or(yy3<yy0) then confusion("m"); 6920@:this can't happen m}{\quad m@> 6921l:=16; bisect_ptr:=0;@/ 6922x1:=xx1-xx0; x2:=xx2-xx1; x3:=xx3-xx2; 6923if xx0>=xi_corr then r:=(xx0-xi_corr) mod unity 6924else r:=unity-1-((-xx0+xi_corr-1) mod unity); 6925m:=(xx3-xx0+r) div unity;@/ 6926y1:=yy1-yy0; y2:=yy2-yy1; y3:=yy3-yy2; 6927if yy0>=eta_corr then s:=(yy0-eta_corr) mod unity 6928else s:=unity-1-((-yy0+eta_corr-1) mod unity); 6929n:=(yy3-yy0+s) div unity;@/ 6930if (xx3-xx0>=fraction_one)or(yy3-yy0>=fraction_one) then 6931 @<Divide the variables by two, to avoid overflow problems@>; 6932loop@+ begin continue:@<Make moves for current subinterval; 6933 if bisection is necessary, push the second subinterval 6934 onto the stack, and |goto continue| in order to handle 6935 the first subinterval@>; 6936 if bisect_ptr=0 then return; 6937 @<Remove a subproblem for |make_moves| from the stack@>; 6938 end; 6939exit: end; 6940 6941@ @<Remove a subproblem for |make_moves| from the stack@>= 6942bisect_ptr:=bisect_ptr-move_increment;@/ 6943x1:=stack_x1; x2:=stack_x2; x3:=stack_x3; r:=stack_r; m:=stack_m;@/ 6944y1:=stack_y1; y2:=stack_y2; y3:=stack_y3; s:=stack_s; n:=stack_n;@/ 6945l:=stack_l 6946 6947@ Our variables |(x1,x2,x3)| correspond to $(X_1,X_2,X_3)$ in the notation 6948of the theory developed above. We need to keep them less than $2^{28}$ 6949in order to avoid integer overflow in weird circumstances. 6950For example, data like $x_0=-2^{28}+2^{16}-1$ and $x_1=x_2=x_3=2^{28}-1$ 6951would otherwise be problematical. Hence this part of the code is 6952needed, if only to thwart malicious users. 6953 6954@<Divide the variables by two, to avoid overflow problems@>= 6955begin x1:=half(x1+xi_corr); x2:=half(x2+xi_corr); x3:=half(x3+xi_corr); 6956r:=half(r+xi_corr);@/ 6957y1:=half(y1+eta_corr); y2:=half(y2+eta_corr); y3:=half(y3+eta_corr); 6958s:=half(s+eta_corr);@/ 6959l:=15; 6960end 6961 6962@ @<Make moves...@>= 6963if m=0 then @<Move upward |n| steps@> 6964else if n=0 then @<Move to the right |m| steps@> 6965else if m+n=2 then @<Make one move of each kind@> 6966else begin incr(l); stack_l:=l;@/ 6967 stack_x3:=x3; stack_x2:=half(x2+x3+xi_corr); x2:=half(x1+x2+xi_corr); 6968 x3:=half(x2+stack_x2+xi_corr); stack_x1:=x3;@/ 6969 r:=r+r+xi_corr; t:=x1+x2+x3+r;@/ 6970 q:=t div two_to_the[l]; stack_r:=t mod two_to_the[l];@/ 6971 stack_m:=m-q; m:=q;@/ 6972 stack_y3:=y3; stack_y2:=half(y2+y3+eta_corr); y2:=half(y1+y2+eta_corr); 6973 y3:=half(y2+stack_y2+eta_corr); stack_y1:=y3;@/ 6974 s:=s+s+eta_corr; u:=y1+y2+y3+s;@/ 6975 q:=u div two_to_the[l]; stack_s:=u mod two_to_the[l];@/ 6976 stack_n:=n-q; n:=q;@/ 6977 bisect_ptr:=bisect_ptr+move_increment; goto continue; 6978 end 6979 6980@ @<Move upward |n| steps@>= 6981while n>0 do 6982 begin incr(move_ptr); move[move_ptr]:=1; decr(n); 6983 end 6984 6985@ @<Move to the right |m| steps@>= 6986move[move_ptr]:=move[move_ptr]+m 6987 6988@ @<Make one move of each kind@>= 6989begin r:=two_to_the[l]-r; s:=two_to_the[l]-s;@/ 6990while l<30 do 6991 begin x3a:=x3; x2a:=half(x2+x3+xi_corr); x2:=half(x1+x2+xi_corr); 6992 x3:=half(x2+x2a+xi_corr); 6993 t:=x1+x2+x3; r:=r+r-xi_corr;@/ 6994 y3a:=y3; y2a:=half(y2+y3+eta_corr); y2:=half(y1+y2+eta_corr); 6995 y3:=half(y2+y2a+eta_corr); 6996 u:=y1+y2+y3; s:=s+s-eta_corr;@/ 6997 if t<r then if u<s then @<Switch to the right subinterval@> 6998 else begin @<Move up then right@>; goto done; 6999 end 7000 else if u<s then 7001 begin @<Move right then up@>; goto done; 7002 end; 7003 incr(l); 7004 end; 7005r:=r-xi_corr; s:=s-eta_corr; 7006if ab_vs_cd(x1+x2+x3,s,y1+y2+y3,r)-xi_corr>=0 then @<Move right then up@> 7007 else @<Move up then right@>; 7008done: 7009end 7010 7011@ @<Switch to the right subinterval@>= 7012begin x1:=x3; x2:=x2a; x3:=x3a; r:=r-t; 7013y1:=y3; y2:=y2a; y3:=y3a; s:=s-u; 7014end 7015 7016@ @<Move right then up@>= 7017begin incr(move[move_ptr]); incr(move_ptr); move[move_ptr]:=1; 7018end 7019 7020@ @<Move up then right@>= 7021begin incr(move_ptr); move[move_ptr]:=2; 7022end 7023 7024@ After |make_moves| has acted, possibly for several curves that move toward 7025the same octant, a ``smoothing'' operation might be done on the |move| array. 7026This removes optical glitches that can arise even when the curve has been 7027digitized without rounding errors. 7028 7029The smoothing process replaces the integers $a_0\ldots a_n$ in 7030|move[b..t]| by ``smoothed'' integers $a_0'\ldots a_n'$ defined as 7031follows: 7032$$a_k'=a_k+\delta\k-\delta_k;\qquad 7033\delta_k=\cases{+1,&if $1<k<n$ and $a_{k-2}\G a_{k-1}\ll a_k\G a\k$;\cr 7034-1,&if $1<k<n$ and $a_{k-2}\L a_{k-1}\gg a_k\L a\k$;\cr 70350,&otherwise.\cr}$$ 7036Here $a\ll b$ means that $a\L b-2$, and $a\gg b$ means that $a\G b+2$. 7037 7038The smoothing operation is symmetric in the sense that, if $a_0\ldots a_n$ 7039smoothes to $a_0'\ldots a_n'$, then the reverse sequence $a_n\ldots a_0$ 7040smoothes to $a_n'\ldots a_0'$; also the complementary sequence 7041$(m-a_0)\ldots(m-a_n)$ smoothes to $(m-a_0')\ldots(m-a_n')$. 7042We have $a_0'+\cdots+a_n'=a_0+\cdots+a_n$ because $\delta_0=\delta_{n+1}=0$. 7043 7044@p procedure smooth_moves(@!b,@!t:integer); 7045var@!k:1..move_size; {index into |move|} 7046@!a,@!aa,@!aaa:integer; {original values of |move[k],move[k-1],move[k-2]|} 7047begin if t-b>=3 then 7048 begin k:=b+2; aa:=move[k-1]; aaa:=move[k-2]; 7049 repeat a:=move[k]; 7050 if abs(a-aa)>1 then 7051 @<Increase and decrease |move[k-1]| and |move[k]| by $\delta_k$@>; 7052 incr(k); aaa:=aa; aa:=a; 7053 until k=t; 7054 end; 7055end; 7056 7057@ @<Increase and decrease |move[k-1]| and |move[k]| by $\delta_k$@>= 7058if a>aa then 7059 begin if aaa>=aa then if a>=move[k+1] then 7060 begin incr(move[k-1]); move[k]:=a-1; 7061 end; 7062 end 7063else begin if aaa<=aa then if a<=move[k+1] then 7064 begin decr(move[k-1]); move[k]:=a+1; 7065 end; 7066 end 7067 7068@* \[20] Edge structures. 7069Now we come to \MF's internal scheme for representing what the user can 7070actually ``see,'' the edges between pixels. Each pixel has an integer 7071weight, obtained by summing the weights on all edges to its left. \MF\ 7072represents only the nonzero edge weights, since most of the edges are 7073weightless; in this way, the data storage requirements grow only linearly 7074with respect to the number of pixels per point, even though two-dimensional 7075data is being represented. (Well, the actual dependence on the underlying 7076resolution is order $n\log n$, but the the $\log n$ factor is buried in our 7077implicit restriction on the maximum raster size.) The sum of all edge 7078weights in each row should be zero. 7079 7080The data structure for edge weights must be compact and flexible, 7081yet it should support efficient updating and display operations. We 7082want to be able to have many different edge structures in memory at 7083once, and we want the computer to be able to translate them, reflect them, 7084and/or merge them together with relative ease. 7085 7086\MF's solution to this problem requires one single-word node per 7087nonzero edge weight, plus one two-word node for each row in a contiguous 7088set of rows. There's also a header node that provides global information 7089about the entire structure. 7090 7091@ Let's consider the edge-weight nodes first. The |info| field of such 7092nodes contains both an $m$~value and a weight~$w$, in the form 7093$8m+w+c$, where $c$ is a constant that depends on data found in the header. 7094We shall consider $c$ in detail later; for now, it's best just to think 7095of it as a way to compensate for the fact that $m$ and~$w$ can be negative, 7096together with the fact that an |info| field must have a value between 7097|min_halfword| and |max_halfword|. The $m$ value is an unscaled $x$~coordinate, 7098so it satisfies $\vert m\vert< 70994096$; the $w$ value is always in the range $1\L\vert w\vert\L3$. We can 7100unpack the data in the |info| field by fetching |ho(info(p))= 7101info(p)-min_halfword| and dividing this nonnegative number by~8; 7102the constant~$c$ will be chosen so that the remainder of this division 7103is $4+w$. Thus, for example, a remainder of~3 will correspond to 7104the edge weight $w=-1$. 7105 7106Every row of an edge structure contains two lists of such edge-weight 7107nodes, called the |sorted| and |unsorted| lists, linked together by their 7108|link| fields in the normal way. The difference between them is that we 7109always have |info(p)<=info(link(p))| in the |sorted| list, but there's no 7110such restriction on the elements of the |unsorted| list. The reason for 7111this distinction is that it would take unnecessarily long to maintain 7112edge-weight lists in sorted order while they're being updated; but when we 7113need to process an entire row from left to right in order of the 7114$m$~values, it's fairly easy and quick to sort a short list of unsorted 7115elements and to merge them into place among their sorted cohorts. 7116Furthermore, the fact that the |unsorted| list is empty can sometimes be 7117used to good advantage, because it allows us to conclude that a particular 7118row has not changed since the last time we sorted it. 7119 7120The final |link| of the |sorted| list will be |sentinel|, which points to 7121a special one-word node whose |info| field is essentially infinite; this 7122facilitates the sorting and merging operations. The final |link| of the 7123|unsorted| list will be either |null| or |void|, where |void=null+1| 7124is used to avoid redisplaying data that has not changed: 7125A |void| value is stored at the head of the 7126unsorted list whenever the corresponding row has been displayed. 7127 7128@d zero_w=4 7129@d void==null+1 7130 7131@<Initialize table entries...@>= 7132info(sentinel):=max_halfword; {|link(sentinel)=null|} 7133 7134@ The rows themselves are represented by row header nodes that 7135contain four link fields. Two of these four, |sorted| and |unsorted|, 7136point to the first items of the edge-weight lists just mentioned. 7137The other two, |link| and |knil|, point to the headers of the two 7138adjacent rows. If |p| points to the header for row number~|n|, then 7139|link(p)| points up to the header for row~|n+1|, and |knil(p)| points 7140down to the header for row~|n-1|. This double linking makes it 7141convenient to move through consecutive rows either upward or downward; 7142as usual, we have |link(knil(p))=knil(link(p))=p| for all row headers~|p|. 7143 7144The row associated with a given value of |n| contains weights for 7145edges that run between the lattice points |(m,n)| and |(m,n+1)|. 7146 7147@d knil==info {inverse of the |link| field, in a doubly linked list} 7148@d sorted_loc(#)==#+1 {where the |sorted| link field resides} 7149@d sorted(#)==link(sorted_loc(#)) {beginning of the list of sorted edge weights} 7150@d unsorted(#)==info(#+1) {beginning of the list of unsorted edge weights} 7151@d row_node_size=2 {number of words in a row header node} 7152 7153@ The main header node |h| for an edge structure has |link| and |knil| 7154fields that link it above the topmost row and below the bottommost row. 7155It also has fields called |m_min|, |m_max|, |n_min|, and |n_max| that 7156bound the current extent of the edge data: All |m| values in edge-weight 7157nodes should lie between |m_min(h)-4096| and |m_max(h)-4096|, inclusive. 7158Furthermore the topmost row header, pointed to by |knil(h)|, 7159is for row number |n_max(h)-4096|; the bottommost row header, pointed to by 7160|link(h)|, is for row number |n_min(h)-4096|. 7161 7162The offset constant |c| that's used in all of the edge-weight data is 7163represented implicitly in |m_offset(h)|; its actual value is 7164$$\hbox{|c=min_halfword+zero_w+8*m_offset(h)|.}$$ 7165Notice that it's possible to shift an entire edge structure by an 7166amount $(\Delta m,\Delta n)$ by adding $\Delta n$ to |n_min(h)| and |n_max(h)|, 7167adding $\Delta m$ to |m_min(h)| and |m_max(h)|, and subtracting 7168$\Delta m$ from |m_offset(h)|; 7169none of the other edge data needs to be modified. Initially the |m_offset| 7170field is~4096, but it will change if the user requests such a shift. 7171The contents of these five fields should always be positive and less than 71728192; |n_max| should, in fact, be less than 8191. Furthermore 7173|m_min+m_offset-4096| and |m_max+m_offset-4096| must also lie strictly 7174between 0 and 8192, so that the |info| fields of edge-weight nodes will 7175fit in a halfword. 7176 7177The header node of an edge structure also contains two somewhat unusual 7178fields that are called |last_window(h)| and |last_window_time(h)|. When this 7179structure is displayed in window~|k| of the user's screen, after that 7180window has been updated |t| times, \MF\ sets |last_window(h):=k| and 7181|last_window_time(h):=t|; it also sets |unsorted(p):=void| for all row 7182headers~|p|, after merging any existing unsorted weights with the sorted 7183ones. A subsequent display in the same window will be able to avoid 7184redisplaying rows whose |unsorted| list is still |void|, if the window 7185hasn't been used for something else in the meantime. 7186 7187A pointer to the row header of row |n_pos(h)-4096| is provided in 7188|n_rover(h)|. Most of the algorithms that update an edge structure 7189are able to get by without random row references; they usually 7190access rows that are neighbors of each other or of the current |n_pos| row. 7191Exception: If |link(h)=h| (so that the edge structure contains 7192no rows), we have |n_rover(h)=h|, and |n_pos(h)| is irrelevant. 7193 7194@d zero_field=4096 {amount added to coordinates to make them positive} 7195@d n_min(#)==info(#+1) {minimum row number present, plus |zero_field|} 7196@d n_max(#)==link(#+1) {maximum row number present, plus |zero_field|} 7197@d m_min(#)==info(#+2) {minimum column number present, plus |zero_field|} 7198@d m_max(#)==link(#+2) {maximum column number present, plus |zero_field|} 7199@d m_offset(#)==info(#+3) {translation of $m$ data in edge-weight nodes} 7200@d last_window(#)==link(#+3) {the last display went into this window} 7201@d last_window_time(#)==mem[#+4].int {after this many window updates} 7202@d n_pos(#)==info(#+5) {the row currently in |n_rover|, plus |zero_field|} 7203@d n_rover(#)==link(#+5) {a row recently referenced} 7204@d edge_header_size=6 {number of words in an edge-structure header} 7205@d valid_range(#)==(abs(#-4096)<4096) {is |#| strictly between 0 and 8192?} 7206@d empty_edges(#)==link(#)=# {are there no rows in this edge header?} 7207 7208@p procedure init_edges(@!h:pointer); {initialize an edge header to null values} 7209begin knil(h):=h; link(h):=h;@/ 7210n_min(h):=zero_field+4095; n_max(h):=zero_field-4095; 7211m_min(h):=zero_field+4095; m_max(h):=zero_field-4095; 7212m_offset(h):=zero_field;@/ 7213last_window(h):=0; last_window_time(h):=0;@/ 7214n_rover(h):=h; n_pos(h):=0;@/ 7215end; 7216 7217@ When a lot of work is being done on a particular edge structure, we plant 7218a pointer to its main header in the global variable |cur_edges|. 7219This saves us from having to pass this pointer as a parameter over and 7220over again between subroutines. 7221 7222Similarly, |cur_wt| is a global weight that is being used by several 7223procedures at once. 7224 7225@<Glob...@>= 7226@!cur_edges:pointer; {the edge structure of current interest} 7227@!cur_wt:integer; {the edge weight of current interest} 7228 7229@ The |fix_offset| routine goes through all the edge-weight nodes of 7230|cur_edges| and adds a constant to their |info| fields, so that 7231|m_offset(cur_edges)| can be brought back to |zero_field|. (This 7232is necessary only in unusual cases when the offset has gotten too 7233large or too small.) 7234 7235@p procedure fix_offset; 7236var @!p,@!q:pointer; {list traversers} 7237@!delta:integer; {the amount of change} 7238begin delta:=8*(m_offset(cur_edges)-zero_field); 7239m_offset(cur_edges):=zero_field; 7240q:=link(cur_edges); 7241while q<>cur_edges do 7242 begin p:=sorted(q); 7243 while p<>sentinel do 7244 begin info(p):=info(p)-delta; p:=link(p); 7245 end; 7246 p:=unsorted(q); 7247 while p>void do 7248 begin info(p):=info(p)-delta; p:=link(p); 7249 end; 7250 q:=link(q); 7251 end; 7252end; 7253 7254@ The |edge_prep| routine makes the |cur_edges| structure ready to 7255accept new data whose coordinates satisfy |ml<=m<=mr| and |nl<=n<=nr-1|, 7256assuming that |-4096<ml<=mr<4096| and |-4096<nl<=nr<4096|. It makes 7257appropriate adjustments to |m_min|, |m_max|, |n_min|, and |n_max|, 7258adding new empty rows if necessary. 7259 7260@p procedure edge_prep(@!ml,@!mr,@!nl,@!nr:integer); 7261var @!delta:halfword; {amount of change} 7262@!p,@!q:pointer; {for list manipulation} 7263begin ml:=ml+zero_field; mr:=mr+zero_field; 7264nl:=nl+zero_field; nr:=nr-1+zero_field;@/ 7265if ml<m_min(cur_edges) then m_min(cur_edges):=ml; 7266if mr>m_max(cur_edges) then m_max(cur_edges):=mr; 7267if not valid_range(m_min(cur_edges)+m_offset(cur_edges)-zero_field) or@| 7268 not valid_range(m_max(cur_edges)+m_offset(cur_edges)-zero_field) then 7269 fix_offset; 7270if empty_edges(cur_edges) then {there are no rows} 7271 begin n_min(cur_edges):=nr+1; n_max(cur_edges):=nr; 7272 end; 7273if nl<n_min(cur_edges) then 7274 @<Insert exactly |n_min(cur_edges)-nl| empty rows at the bottom@>; 7275if nr>n_max(cur_edges) then 7276 @<Insert exactly |nr-n_max(cur_edges)| empty rows at the top@>; 7277end; 7278 7279@ @<Insert exactly |n_min(cur_edges)-nl| empty rows at the bottom@>= 7280begin delta:=n_min(cur_edges)-nl; n_min(cur_edges):=nl; 7281p:=link(cur_edges); 7282repeat q:=get_node(row_node_size); sorted(q):=sentinel; unsorted(q):=void; 7283knil(p):=q; link(q):=p; p:=q; decr(delta); 7284until delta=0; 7285knil(p):=cur_edges; link(cur_edges):=p; 7286if n_rover(cur_edges)=cur_edges then n_pos(cur_edges):=nl-1; 7287end 7288 7289@ @<Insert exactly |nr-n_max(cur_edges)| empty rows at the top@>= 7290begin delta:=nr-n_max(cur_edges); n_max(cur_edges):=nr; 7291p:=knil(cur_edges); 7292repeat q:=get_node(row_node_size); sorted(q):=sentinel; unsorted(q):=void; 7293link(p):=q; knil(q):=p; p:=q; decr(delta); 7294until delta=0; 7295link(p):=cur_edges; knil(cur_edges):=p; 7296if n_rover(cur_edges)=cur_edges then n_pos(cur_edges):=nr+1; 7297end 7298 7299@ The |print_edges| subroutine gives a symbolic rendition of an edge 7300structure, for use in `\&{show}' commands. A rather terse output 7301format has been chosen since edge structures can grow quite large. 7302 7303@<Declare subroutines for printing expressions@>= 7304@t\4@>@<Declare the procedure called |print_weight|@>@;@/ 7305procedure print_edges(@!s:str_number;@!nuline:boolean;@!x_off,@!y_off:integer); 7306var @!p,@!q,@!r:pointer; {for list traversal} 7307@!n:integer; {row number} 7308begin print_diagnostic("Edge structure",s,nuline); 7309p:=knil(cur_edges); n:=n_max(cur_edges)-zero_field; 7310while p<>cur_edges do 7311 begin q:=unsorted(p); r:=sorted(p); 7312 if(q>void)or(r<>sentinel) then 7313 begin print_nl("row "); print_int(n+y_off); print_char(":"); 7314 while q>void do 7315 begin print_weight(q,x_off); q:=link(q); 7316 end; 7317 print(" |"); 7318 while r<>sentinel do 7319 begin print_weight(r,x_off); r:=link(r); 7320 end; 7321 end; 7322 p:=knil(p); decr(n); 7323 end; 7324end_diagnostic(true); 7325end; 7326 7327@ @<Declare the procedure called |print_weight|@>= 7328procedure print_weight(@!q:pointer;@!x_off:integer); 7329var @!w,@!m:integer; {unpacked weight and coordinate} 7330@!d:integer; {temporary data register} 7331begin d:=ho(info(q)); w:=d mod 8; m:=(d div 8)-m_offset(cur_edges); 7332if file_offset>max_print_line-9 then print_nl(" ") 7333else print_char(" "); 7334print_int(m+x_off); 7335while w>zero_w do 7336 begin print_char("+"); decr(w); 7337 end; 7338while w<zero_w do 7339 begin print_char("-"); incr(w); 7340 end; 7341end; 7342 7343@ Here's a trivial subroutine that copies an edge structure. (Let's hope 7344that the given structure isn't too gigantic.) 7345 7346@p function copy_edges(@!h:pointer):pointer; 7347var @!p,@!r:pointer; {variables that traverse the given structure} 7348@!hh,@!pp,@!qq,@!rr,@!ss:pointer; {variables that traverse the new structure} 7349begin hh:=get_node(edge_header_size); 7350mem[hh+1]:=mem[h+1]; mem[hh+2]:=mem[h+2]; 7351mem[hh+3]:=mem[h+3]; mem[hh+4]:=mem[h+4]; {we've now copied |n_min|, |n_max|, 7352 |m_min|, |m_max|, |m_offset|, |last_window|, and |last_window_time|} 7353n_pos(hh):=n_max(hh)+1;n_rover(hh):=hh;@/ 7354p:=link(h); qq:=hh; 7355while p<>h do 7356 begin pp:=get_node(row_node_size); link(qq):=pp; knil(pp):=qq; 7357 @<Copy both |sorted| and |unsorted| lists of |p| to |pp|@>; 7358 p:=link(p); qq:=pp; 7359 end; 7360link(qq):=hh; knil(hh):=qq; 7361copy_edges:=hh; 7362end; 7363 7364@ @<Copy both |sorted| and |unsorted|...@>= 7365r:=sorted(p); rr:=sorted_loc(pp); {|link(rr)=sorted(pp)|} 7366while r<>sentinel do 7367 begin ss:=get_avail; link(rr):=ss; rr:=ss; info(rr):=info(r);@/ 7368 r:=link(r); 7369 end; 7370link(rr):=sentinel;@/ 7371r:=unsorted(p); rr:=temp_head; 7372while r>void do 7373 begin ss:=get_avail; link(rr):=ss; rr:=ss; info(rr):=info(r);@/ 7374 r:=link(r); 7375 end; 7376link(rr):=r; unsorted(pp):=link(temp_head) 7377 7378@ Another trivial routine flips |cur_edges| about the |x|-axis 7379(i.e., negates all the |y| coordinates), assuming that at least 7380one row is present. 7381 7382@p procedure y_reflect_edges; 7383var @!p,@!q,@!r:pointer; {list manipulation registers} 7384begin p:=n_min(cur_edges); 7385n_min(cur_edges):=zero_field+zero_field-1-n_max(cur_edges); 7386n_max(cur_edges):=zero_field+zero_field-1-p; 7387n_pos(cur_edges):=zero_field+zero_field-1-n_pos(cur_edges);@/ 7388p:=link(cur_edges); q:=cur_edges; {we assume that |p<>q|} 7389repeat r:=link(p); link(p):=q; knil(q):=p; q:=p; p:=r; 7390until q=cur_edges; 7391last_window_time(cur_edges):=0; 7392end; 7393 7394@ It's somewhat more difficult, yet not too hard, to reflect about the |y|-axis. 7395 7396@p procedure x_reflect_edges; 7397var @!p,@!q,@!r,@!s:pointer; {list manipulation registers} 7398@!m:integer; {|info| fields will be reflected with respect to this number} 7399begin p:=m_min(cur_edges); 7400m_min(cur_edges):=zero_field+zero_field-m_max(cur_edges); 7401m_max(cur_edges):=zero_field+zero_field-p; 7402m:=(zero_field+m_offset(cur_edges))*8+zero_w+min_halfword+zero_w+min_halfword; 7403m_offset(cur_edges):=zero_field; 7404p:=link(cur_edges); 7405repeat @<Reflect the edge-and-weight data in |sorted(p)|@>; 7406@<Reflect the edge-and-weight data in |unsorted(p)|@>; 7407p:=link(p); 7408until p=cur_edges; 7409last_window_time(cur_edges):=0; 7410end; 7411 7412@ We want to change the sign of the weight as we change the sign of the 7413|x|~coordinate. Fortunately, it's easier to do this than to negate 7414one without the other. 7415 7416@<Reflect the edge-and-weight data in |unsorted(p)|@>= 7417q:=unsorted(p); 7418while q>void do 7419 begin info(q):=m-info(q); q:=link(q); 7420 end 7421 7422@ Reversing the order of a linked list is best thought of as the process of 7423popping nodes off one stack and pushing them on another. In this case we 7424pop from stack~|q| and push to stack~|r|. 7425 7426@<Reflect the edge-and-weight data in |sorted(p)|@>= 7427q:=sorted(p); r:=sentinel; 7428while q<>sentinel do 7429 begin s:=link(q); link(q):=r; r:=q; info(r):=m-info(q); q:=s; 7430 end; 7431sorted(p):=r 7432 7433@ Now let's multiply all the $y$~coordinates of a nonempty edge structure 7434by a small integer $s>1$: 7435 7436@p procedure y_scale_edges(@!s:integer); 7437var @!p,@!q,@!pp,@!r,@!rr,@!ss:pointer; {list manipulation registers} 7438@!t:integer; {replication counter} 7439begin if (s*(n_max(cur_edges)+1-zero_field)>=4096) or@| 7440 (s*(n_min(cur_edges)-zero_field)<=-4096) then 7441 begin print_err("Scaled picture would be too big"); 7442@.Scaled picture...big@> 7443 help3("I can't yscale the picture as requested---it would")@/ 7444 ("make some coordinates too large or too small.")@/ 7445 ("Proceed, and I'll omit the transformation."); 7446 put_get_error; 7447 end 7448else begin n_max(cur_edges):=s*(n_max(cur_edges)+1-zero_field)-1+zero_field; 7449 n_min(cur_edges):=s*(n_min(cur_edges)-zero_field)+zero_field; 7450 @<Replicate every row exactly $s$ times@>; 7451 last_window_time(cur_edges):=0; 7452 end; 7453end; 7454 7455@ @<Replicate...@>= 7456p:=cur_edges; 7457repeat q:=p; p:=link(p); 7458for t:=2 to s do 7459 begin pp:=get_node(row_node_size); link(q):=pp; knil(p):=pp; 7460 link(pp):=p; knil(pp):=q; q:=pp; 7461 @<Copy both |sorted| and |unsorted|...@>; 7462 end; 7463until link(p)=cur_edges 7464 7465@ Scaling the $x$~coordinates is, of course, our next task. 7466 7467@p procedure x_scale_edges(@!s:integer); 7468var @!p,@!q:pointer; {list manipulation registers} 7469@!t:0..65535; {unpacked |info| field} 7470@!w:0..7; {unpacked weight} 7471@!delta:integer; {amount added to scaled |info|} 7472begin if (s*(m_max(cur_edges)-zero_field)>=4096) or@| 7473 (s*(m_min(cur_edges)-zero_field)<=-4096) then 7474 begin print_err("Scaled picture would be too big"); 7475@.Scaled picture...big@> 7476 help3("I can't xscale the picture as requested---it would")@/ 7477 ("make some coordinates too large or too small.")@/ 7478 ("Proceed, and I'll omit the transformation."); 7479 put_get_error; 7480 end 7481else if (m_max(cur_edges)<>zero_field)or(m_min(cur_edges)<>zero_field) then 7482 begin m_max(cur_edges):=s*(m_max(cur_edges)-zero_field)+zero_field; 7483 m_min(cur_edges):=s*(m_min(cur_edges)-zero_field)+zero_field; 7484 delta:=8*(zero_field-s*m_offset(cur_edges))+min_halfword; 7485 m_offset(cur_edges):=zero_field;@/ 7486 @<Scale the $x$~coordinates of each row by $s$@>; 7487 last_window_time(cur_edges):=0; 7488 end; 7489end; 7490 7491@ The multiplications cannot overflow because we know that |s<4096|. 7492 7493@<Scale the $x$~coordinates of each row by $s$@>= 7494q:=link(cur_edges); 7495repeat p:=sorted(q); 7496while p<>sentinel do 7497 begin t:=ho(info(p)); w:=t mod 8; info(p):=(t-w)*s+w+delta; p:=link(p); 7498 end; 7499p:=unsorted(q); 7500while p>void do 7501 begin t:=ho(info(p)); w:=t mod 8; info(p):=(t-w)*s+w+delta; p:=link(p); 7502 end; 7503q:=link(q); 7504until q=cur_edges 7505 7506@ Here is a routine that changes the signs of all the weights, without 7507changing anything else. 7508 7509@p procedure negate_edges(@!h:pointer); 7510label done; 7511var @!p,@!q,@!r,@!s,@!t,@!u:pointer; {structure traversers} 7512begin p:=link(h); 7513while p<>h do 7514 begin q:=unsorted(p); 7515 while q>void do 7516 begin info(q):=8-2*((ho(info(q))) mod 8)+info(q); q:=link(q); 7517 end; 7518 q:=sorted(p); 7519 if q<>sentinel then 7520 begin repeat info(q):=8-2*((ho(info(q))) mod 8)+info(q); q:=link(q); 7521 until q=sentinel; 7522 @<Put the list |sorted(p)| back into sort@>; 7523 end; 7524 p:=link(p); 7525 end; 7526last_window_time(h):=0; 7527end; 7528 7529@ \MF\ would work even if the code in this section were omitted, because 7530a list of edge-and-weight data that is sorted only by 7531|m| but not~|w| turns out to be good enough for correct operation. 7532However, the author decided not to make the program even trickier than 7533it is already, since |negate_edges| isn't needed very often. 7534The simpler-to-state condition, ``keep the |sorted| list fully sorted,'' 7535is therefore being preserved at the cost of extra computation. 7536 7537@<Put the list |sorted(p)|...@>= 7538u:=sorted_loc(p); q:=link(u); r:=q; s:=link(r); {|q=sorted(p)|} 7539loop@+ if info(s)>info(r) then 7540 begin link(u):=q; 7541 if s=sentinel then goto done; 7542 u:=r; q:=s; r:=q; s:=link(r); 7543 end 7544 else begin t:=s; s:=link(t); link(t):=q; q:=t; 7545 end; 7546done: link(r):=sentinel 7547 7548@ The |unsorted| edges of a row are merged into the |sorted| ones by 7549a subroutine called |sort_edges|. It uses simple insertion sort, 7550followed by a merge, because the unsorted list is supposedly quite short. 7551However, the unsorted list is assumed to be nonempty. 7552 7553@p procedure sort_edges(@!h:pointer); {|h| is a row header} 7554label done; 7555var @!k:halfword; {key register that we compare to |info(q)|} 7556@!p,@!q,@!r,@!s:pointer; 7557begin r:=unsorted(h); unsorted(h):=null; 7558p:=link(r); link(r):=sentinel; link(temp_head):=r; 7559while p>void do {sort node |p| into the list that starts at |temp_head|} 7560 begin k:=info(p); q:=temp_head; 7561 repeat r:=q; q:=link(r); 7562 until k<=info(q); 7563 link(r):=p; r:=link(p); link(p):=q; p:=r; 7564 end; 7565@<Merge the |temp_head| list into |sorted(h)|@>; 7566end; 7567 7568@ In this step we use the fact that |sorted(h)=link(sorted_loc(h))|. 7569 7570@<Merge the |temp_head| list into |sorted(h)|@>= 7571begin r:=sorted_loc(h); q:=link(r); p:=link(temp_head); 7572loop@+ begin k:=info(p); 7573 while k>info(q) do 7574 begin r:=q; q:=link(r); 7575 end; 7576 link(r):=p; s:=link(p); link(p):=q; 7577 if s=sentinel then goto done; 7578 r:=p; p:=s; 7579 end; 7580done:end 7581 7582@ The |cull_edges| procedure ``optimizes'' an edge structure by making all 7583the pixel weights either |w_out| or~|w_in|. The weight will be~|w_in| after the 7584operation if and only if it was in the closed interval |[w_lo,w_hi]| 7585before, where |w_lo<=w_hi|. Either |w_out| or |w_in| is zero, while the other is 7586$\pm1$, $\pm2$, or $\pm3$. The parameters will be such that zero-weight 7587pixels will remain of weight zero. (This is fortunate, 7588because there are infinitely many of them.) 7589 7590The procedure also computes the tightest possible bounds on the resulting 7591data, by updating |m_min|, |m_max|, |n_min|, and~|n_max|. 7592 7593@p procedure cull_edges(@!w_lo,@!w_hi,@!w_out,@!w_in:integer); 7594label done; 7595var @!p,@!q,@!r,@!s:pointer; {for list manipulation} 7596@!w:integer; {new weight after culling} 7597@!d:integer; {data register for unpacking} 7598@!m:integer; {the previous column number, including |m_offset|} 7599@!mm:integer; {the next column number, including |m_offset|} 7600@!ww:integer; {accumulated weight before culling} 7601@!prev_w:integer; {value of |w| before column |m|} 7602@!n,@!min_n,@!max_n:pointer; {current and extreme row numbers} 7603@!min_d,@!max_d:pointer; {extremes of the new edge-and-weight data} 7604begin min_d:=max_halfword; max_d:=min_halfword; 7605min_n:=max_halfword; max_n:=min_halfword;@/ 7606p:=link(cur_edges); n:=n_min(cur_edges); 7607while p<>cur_edges do 7608 begin if unsorted(p)>void then sort_edges(p); 7609 if sorted(p)<>sentinel then 7610 @<Cull superfluous edge-weight entries from |sorted(p)|@>; 7611 p:=link(p); incr(n); 7612 end; 7613@<Delete empty rows at the top and/or bottom; 7614 update the boundary values in the header@>; 7615last_window_time(cur_edges):=0; 7616end; 7617 7618@ The entire |sorted| list is returned to available memory in this step; 7619a new list is built starting (temporarily) at |temp_head|. 7620Since several edges can occur at the same column, we need to be looking 7621ahead of where the actual culling takes place. This means that it's 7622slightly tricky to get the iteration started and stopped. 7623 7624@<Cull superfluous...@>= 7625begin r:=temp_head; q:=sorted(p); ww:=0; m:=1000000; prev_w:=0; 7626loop@+ begin if q=sentinel then mm:=1000000 7627 else begin d:=ho(info(q)); mm:=d div 8; ww:=ww+(d mod 8)-zero_w; 7628 end; 7629 if mm>m then 7630 begin @<Insert an edge-weight for edge |m|, if the new pixel 7631 weight has changed@>; 7632 if q=sentinel then goto done; 7633 end; 7634 m:=mm; 7635 if ww>=w_lo then if ww<=w_hi then w:=w_in 7636 else w:=w_out 7637 else w:=w_out; 7638 s:=link(q); free_avail(q); q:=s; 7639 end; 7640done: link(r):=sentinel; sorted(p):=link(temp_head); 7641if r<>temp_head then @<Update the max/min amounts@>; 7642end 7643 7644@ @<Insert an edge-weight for edge |m|, if...@>= 7645if w<>prev_w then 7646 begin s:=get_avail; link(r):=s; 7647 info(s):=8*m+min_halfword+zero_w+w-prev_w; 7648 r:=s; prev_w:=w; 7649 end 7650 7651@ @<Update the max/min amounts@>= 7652begin if min_n=max_halfword then min_n:=n; 7653max_n:=n; 7654if min_d>info(link(temp_head)) then min_d:=info(link(temp_head)); 7655if max_d<info(r) then max_d:=info(r); 7656end 7657 7658@ @<Delete empty rows at the top and/or bottom...@>= 7659if min_n>max_n then @<Delete all the row headers@> 7660else begin n:=n_min(cur_edges); n_min(cur_edges):=min_n; 7661 while min_n>n do 7662 begin p:=link(cur_edges); link(cur_edges):=link(p); 7663 knil(link(p)):=cur_edges; 7664 free_node(p,row_node_size); incr(n); 7665 end; 7666 n:=n_max(cur_edges); n_max(cur_edges):=max_n; 7667 n_pos(cur_edges):=max_n+1; n_rover(cur_edges):=cur_edges; 7668 while max_n<n do 7669 begin p:=knil(cur_edges); knil(cur_edges):=knil(p); 7670 link(knil(p)):=cur_edges; 7671 free_node(p,row_node_size); decr(n); 7672 end; 7673 m_min(cur_edges):=((ho(min_d)) div 8)-m_offset(cur_edges)+zero_field; 7674 m_max(cur_edges):=((ho(max_d)) div 8)-m_offset(cur_edges)+zero_field; 7675 end 7676 7677@ We get here if the edges have been entirely culled away. 7678 7679@<Delete all the row headers@>= 7680begin p:=link(cur_edges); 7681while p<>cur_edges do 7682 begin q:=link(p); free_node(p,row_node_size); p:=q; 7683 end; 7684init_edges(cur_edges); 7685end 7686 7687 7688@ The last and most difficult routine for transforming an edge structure---and 7689the most interesting one!---is |xy_swap_edges|, which interchanges the 7690r\^^Doles of rows and columns. Its task can be viewed as the job of 7691creating an edge structure that contains only horizontal edges, linked 7692together in columns, given an edge structure that contains only 7693vertical edges linked together in rows; we must do this without changing 7694the implied pixel weights. 7695 7696Given any two adjacent rows of an edge structure, it is not difficult to 7697determine the horizontal edges that lie ``between'' them: We simply look 7698for vertically adjacent pixels that have different weight, and insert 7699a horizontal edge containing the difference in weights. Every horizontal 7700edge determined in this way should be put into an appropriate linked 7701list. Since random access to these linked lists is desirable, we use 7702the |move| array to hold the list heads. If we work through the given 7703edge structure from top to bottom, the constructed lists will not need 7704to be sorted, since they will already be in order. 7705 7706The following algorithm makes use of some ideas suggested by John Hobby. 7707@^Hobby, John Douglas@> 7708It assumes that the edge structure is non-null, i.e., that |link(cur_edges) 7709<>cur_edges|, hence |m_max(cur_edges)>=m_min(cur_edges)|. 7710 7711@p procedure xy_swap_edges; {interchange |x| and |y| in |cur_edges|} 7712label done; 7713var @!m_magic,@!n_magic:integer; {special values that account for offsets} 7714@!p,@!q,@!r,@!s:pointer; {pointers that traverse the given structure} 7715@<Other local variables for |xy_swap_edges|@>@; 7716begin @<Initialize the array of new edge list heads@>; 7717@<Insert blank rows at the top and bottom, and set |p| to the new top row@>; 7718@<Compute the magic offset values@>; 7719repeat q:=knil(p);@+if unsorted(q)>void then sort_edges(q); 7720@<Insert the horizontal edges defined by adjacent rows |p,q|, 7721 and destroy row~|p|@>; 7722p:=q; n_magic:=n_magic-8; 7723until knil(p)=cur_edges; 7724free_node(p,row_node_size); {now all original rows have been recycled} 7725@<Adjust the header to reflect the new edges@>; 7726end; 7727 7728@ Here we don't bother to keep the |link| entries up to date, since the 7729procedure looks only at the |knil| fields as it destroys the former 7730edge structure. 7731 7732@<Insert blank rows at the top and bottom...@>= 7733p:=get_node(row_node_size); sorted(p):=sentinel; unsorted(p):=null;@/ 7734knil(p):=cur_edges; knil(link(cur_edges)):=p; {the new bottom row} 7735p:=get_node(row_node_size); sorted(p):=sentinel; 7736knil(p):=knil(cur_edges); {the new top row} 7737 7738@ The new lists will become |sorted| lists later, so we initialize 7739empty lists to |sentinel|. 7740 7741@<Initialize the array of new edge list heads@>= 7742m_spread:=m_max(cur_edges)-m_min(cur_edges); {this is |>=0| by assumption} 7743if m_spread>move_size then overflow("move table size",move_size); 7744@:METAFONT capacity exceeded move table size}{\quad move table size@> 7745for j:=0 to m_spread do move[j]:=sentinel 7746 7747@ @<Other local variables for |xy_swap_edges|@>= 7748@!m_spread:integer; {the difference between |m_max| and |m_min|} 7749@!j,@!jj:0..move_size; {indices into |move|} 7750@!m,@!mm:integer; {|m| values at vertical edges} 7751@!pd,@!rd:integer; {data fields from edge-and-weight nodes} 7752@!pm,@!rm:integer; {|m| values from edge-and-weight nodes} 7753@!w:integer; {the difference in accumulated weight} 7754@!ww:integer; {as much of |w| that can be stored in a single node} 7755@!dw:integer; {an increment to be added to |w|} 7756 7757@ At the point where we test |w<>0|, variable |w| contains 7758the accumulated weight from edges already passed in 7759row~|p| minus the accumulated weight from edges already passed in row~|q|. 7760 7761@<Insert the horizontal edges defined by adjacent rows |p,q|...@>= 7762r:=sorted(p); free_node(p,row_node_size); p:=r;@/ 7763pd:=ho(info(p)); pm:=pd div 8;@/ 7764r:=sorted(q); rd:=ho(info(r)); rm:=rd div 8; w:=0; 7765loop@+ begin if pm<rm then mm:=pm@+else mm:=rm; 7766 if w<>0 then 7767 @<Insert horizontal edges of weight |w| between |m| and~|mm|@>; 7768 if pd<rd then 7769 begin dw:=(pd mod 8)-zero_w; 7770 @<Advance pointer |p| to the next vertical edge, 7771 after destroying the previous one@>; 7772 end 7773 else begin if r=sentinel then goto done; {|rd=pd=ho(max_halfword)|} 7774 dw:=-((rd mod 8)-zero_w); 7775 @<Advance pointer |r| to the next vertical edge@>; 7776 end; 7777 m:=mm; w:=w+dw; 7778 end; 7779done: 7780 7781@ @<Advance pointer |r| to the next vertical edge@>= 7782r:=link(r); rd:=ho(info(r)); rm:=rd div 8 7783 7784@ @<Advance pointer |p| to the next vertical edge...@>= 7785s:=link(p); free_avail(p); p:=s; pd:=ho(info(p)); pm:=pd div 8 7786 7787@ Certain ``magic'' values are needed to make the following code work, 7788because of the various offsets in our data structure. For now, let's not 7789worry about their precise values; we shall compute |m_magic| and |n_magic| 7790later, after we see what the code looks like. 7791 7792@ @<Insert horizontal edges of weight |w| between |m| and~|mm|@>= 7793if m<>mm then 7794 begin if mm-m_magic>=move_size then confusion("xy"); 7795@:this can't happen xy}{\quad xy@> 7796 extras:=(abs(w)-1) div 3; 7797 if extras>0 then 7798 begin if w>0 then xw:=+3@+else xw:=-3; 7799 ww:=w-extras*xw; 7800 end 7801 else ww:=w; 7802 repeat j:=m-m_magic; 7803 for k:=1 to extras do 7804 begin s:=get_avail; info(s):=n_magic+xw; 7805 link(s):=move[j]; move[j]:=s; 7806 end; 7807 s:=get_avail; info(s):=n_magic+ww; 7808 link(s):=move[j]; move[j]:=s;@/ 7809 incr(m); 7810 until m=mm; 7811 end 7812 7813@ @<Other local variables for |xy...@>= 7814@!extras:integer; {the number of additional nodes to make weights |>3|} 7815@!xw:-3..3; {the additional weight in extra nodes} 7816@!k:integer; {loop counter for inserting extra nodes} 7817 7818@ At the beginning of this step, |move[m_spread]=sentinel|, because no 7819horizontal edges will extend to the right of column |m_max(cur_edges)|. 7820 7821@<Adjust the header to reflect the new edges@>= 7822move[m_spread]:=0; j:=0; 7823while move[j]=sentinel do incr(j); 7824if j=m_spread then init_edges(cur_edges) {all edge weights are zero} 7825else begin mm:=m_min(cur_edges); 7826 m_min(cur_edges):=n_min(cur_edges); 7827 m_max(cur_edges):=n_max(cur_edges)+1; 7828 m_offset(cur_edges):=zero_field; 7829 jj:=m_spread-1; 7830 while move[jj]=sentinel do decr(jj); 7831 n_min(cur_edges):=j+mm; n_max(cur_edges):=jj+mm; q:=cur_edges; 7832 repeat p:=get_node(row_node_size); link(q):=p; knil(p):=q; 7833 sorted(p):=move[j]; unsorted(p):=null; incr(j); q:=p; 7834 until j>jj; 7835 link(q):=cur_edges; knil(cur_edges):=q; 7836 n_pos(cur_edges):=n_max(cur_edges)+1; n_rover(cur_edges):=cur_edges; 7837 last_window_time(cur_edges):=0; 7838 end; 7839 7840@ The values of |m_magic| and |n_magic| can be worked out by trying the 7841code above on a small example; if they work correctly in simple cases, 7842they should work in general. 7843 7844@<Compute the magic offset values@>= 7845m_magic:=m_min(cur_edges)+m_offset(cur_edges)-zero_field; 7846n_magic:=8*n_max(cur_edges)+8+zero_w+min_halfword 7847 7848@ Now let's look at the subroutine that merges the edges from a given 7849edge structure into |cur_edges|. The given edge structure loses all its 7850edges. 7851 7852@p procedure merge_edges(@!h:pointer); 7853label done; 7854var @!p,@!q,@!r,@!pp,@!qq,@!rr:pointer; {list manipulation registers} 7855@!n:integer; {row number} 7856@!k:halfword; {key register that we compare to |info(q)|} 7857@!delta:integer; {change to the edge/weight data} 7858begin if link(h)<>h then 7859 begin if (m_min(h)<m_min(cur_edges))or(m_max(h)>m_max(cur_edges))or@| 7860 (n_min(h)<n_min(cur_edges))or(n_max(h)>n_max(cur_edges)) then 7861 edge_prep(m_min(h)-zero_field,m_max(h)-zero_field, 7862 n_min(h)-zero_field,n_max(h)-zero_field+1); 7863 if m_offset(h)<>m_offset(cur_edges) then 7864 @<Adjust the data of |h| to account for a difference of offsets@>; 7865 n:=n_min(cur_edges); p:=link(cur_edges); pp:=link(h); 7866 while n<n_min(h) do 7867 begin incr(n); p:=link(p); 7868 end; 7869 repeat @<Merge row |pp| into row |p|@>; 7870 pp:=link(pp); p:=link(p); 7871 until pp=h; 7872 end; 7873end; 7874 7875@ @<Adjust the data of |h| to account for a difference of offsets@>= 7876begin pp:=link(h); delta:=8*(m_offset(cur_edges)-m_offset(h)); 7877repeat qq:=sorted(pp); 7878while qq<>sentinel do 7879 begin info(qq):=info(qq)+delta; qq:=link(qq); 7880 end; 7881qq:=unsorted(pp); 7882while qq>void do 7883 begin info(qq):=info(qq)+delta; qq:=link(qq); 7884 end; 7885pp:=link(pp); 7886until pp=h; 7887end 7888 7889@ The |sorted| and |unsorted| lists are merged separately. After this 7890step, row~|pp| will have no edges remaining, since they will all have 7891been merged into row~|p|. 7892 7893@<Merge row |pp|...@>= 7894qq:=unsorted(pp); 7895if qq>void then 7896 if unsorted(p)<=void then unsorted(p):=qq 7897 else begin while link(qq)>void do qq:=link(qq); 7898 link(qq):=unsorted(p); unsorted(p):=unsorted(pp); 7899 end; 7900unsorted(pp):=null; qq:=sorted(pp); 7901if qq<>sentinel then 7902 begin if unsorted(p)=void then unsorted(p):=null; 7903 sorted(pp):=sentinel; r:=sorted_loc(p); q:=link(r); {|q=sorted(p)|} 7904 if q=sentinel then sorted(p):=qq 7905 else loop@+begin k:=info(qq); 7906 while k>info(q) do 7907 begin r:=q; q:=link(r); 7908 end; 7909 link(r):=qq; rr:=link(qq); link(qq):=q; 7910 if rr=sentinel then goto done; 7911 r:=qq; qq:=rr; 7912 end; 7913 end; 7914done: 7915 7916@ The |total_weight| routine computes the total of all pixel weights 7917in a given edge structure. It's not difficult to prove that this is 7918the sum of $(-w)$ times $x$ taken over all edges, 7919where $w$ and~$x$ are the weight and $x$~coordinates stored in an edge. 7920It's not necessary to worry that this quantity will overflow the 7921size of an |integer| register, because it will be less than~$2^{31}$ 7922unless the edge structure has more than 174,762 edges. However, we had 7923better not try to compute it as a |scaled| integer, because a total 7924weight of almost $12\times 2^{12}$ can be produced by only four edges. 7925 7926@p function total_weight(@!h:pointer):integer; {|h| is an edge header} 7927var @!p,@!q:pointer; {variables that traverse the given structure} 7928@!n:integer; {accumulated total so far} 7929@!m:0..65535; {packed $x$ and $w$ values, including offsets} 7930begin n:=0; p:=link(h); 7931while p<>h do 7932 begin q:=sorted(p); 7933 while q<>sentinel do 7934 @<Add the contribution of node |q| to the total weight, 7935 and set |q:=link(q)|@>; 7936 q:=unsorted(p); 7937 while q>void do 7938 @<Add the contribution of node |q| to the total weight, 7939 and set |q:=link(q)|@>; 7940 p:=link(p); 7941 end; 7942total_weight:=n; 7943end; 7944 7945@ It's not necessary to add the offsets to the $x$ coordinates, because 7946an entire edge structure can be shifted without affecting its total weight. 7947Similarly, we don't need to subtract |zero_field|. 7948 7949@<Add the contribution of node |q| to the total weight...@>= 7950begin m:=ho(info(q)); n:=n-((m mod 8)-zero_w)*(m div 8); 7951q:=link(q); 7952end 7953 7954@ So far we've done lots of things to edge structures assuming that 7955edges are actually present, but we haven't seen how edges get created 7956in the first place. Let's turn now to the problem of generating new edges. 7957 7958\MF\ will display new edges as they are being computed, if |tracing_edges| 7959is positive. In order to keep such data reasonably compact, only the 7960points at which the path makes a $90^\circ$ or $180^\circ$ turn are listed. 7961 7962The tracing algorithm must remember some past history in order to suppress 7963unnecessary data. Three variables |trace_x|, |trace_y|, and |trace_yy| 7964provide this history: The last coordinates printed were |(trace_x,trace_y)|, 7965and the previous edge traced ended at |(trace_x,trace_yy)|. Before anything 7966at all has been traced, |trace_x=-4096|. 7967 7968@<Glob...@>= 7969@!trace_x:integer; {$x$~coordinate most recently shown in a trace} 7970@!trace_y:integer; {$y$~coordinate most recently shown in a trace} 7971@!trace_yy:integer; {$y$~coordinate most recently encountered} 7972 7973@ Edge tracing is initiated by the |begin_edge_tracing| routine, 7974continued by the |trace_a_corner| routine, and terminated by the 7975|end_edge_tracing| routine. 7976 7977@p procedure begin_edge_tracing; 7978begin print_diagnostic("Tracing edges","",true); 7979print(" (weight "); print_int(cur_wt); print_char(")"); trace_x:=-4096; 7980end; 7981@# 7982procedure trace_a_corner; 7983begin if file_offset>max_print_line-13 then print_nl(""); 7984print_char("("); print_int(trace_x); print_char(","); print_int(trace_yy); 7985print_char(")"); trace_y:=trace_yy; 7986end; 7987@# 7988procedure end_edge_tracing; 7989begin if trace_x=-4096 then print_nl("(No new edges added.)") 7990@.No new edges added@> 7991else begin trace_a_corner; print_char("."); 7992 end; 7993end_diagnostic(true); 7994end; 7995 7996@ Just after a new edge weight has been put into the |info| field of 7997node~|r|, in row~|n|, the following routine continues an ongoing trace. 7998 7999@p procedure trace_new_edge(@!r:pointer;@!n:integer); 8000var @!d:integer; {temporary data register} 8001@!w:-3..3; {weight associated with an edge transition} 8002@!m,@!n0,@!n1:integer; {column and row numbers} 8003begin d:=ho(info(r)); w:=(d mod 8)-zero_w; m:=(d div 8)-m_offset(cur_edges); 8004if w=cur_wt then 8005 begin n0:=n+1; n1:=n; 8006 end 8007else begin n0:=n; n1:=n+1; 8008 end; {the edges run from |(m,n0)| to |(m,n1)|} 8009if m<>trace_x then 8010 begin if trace_x=-4096 then 8011 begin print_nl(""); trace_yy:=n0; 8012 end 8013 else if trace_yy<>n0 then print_char("?") {shouldn't happen} 8014 else trace_a_corner; 8015 trace_x:=m; trace_a_corner; 8016 end 8017else begin if n0<>trace_yy then print_char("!"); {shouldn't happen} 8018 if ((n0<n1)and(trace_y>trace_yy))or((n0>n1)and(trace_y<trace_yy)) then 8019 trace_a_corner; 8020 end; 8021trace_yy:=n1; 8022end; 8023 8024@ One way to put new edge weights into an edge structure is to use the 8025following routine, which simply draws a straight line from |(x0,y0)| to 8026|(x1,y1)|. More precisely, it introduces weights for the edges of the 8027discrete path $\bigl(\lfloor t[x_0,x_1]+{1\over2}+\epsilon\rfloor, 8028\lfloor t[y_0,y_1]+{1\over2}+\epsilon\delta\rfloor\bigr)$, 8029as $t$ varies from 0 to~1, where $\epsilon$ and $\delta$ are extremely small 8030positive numbers. 8031 8032The structure header is assumed to be |cur_edges|; downward edge weights 8033will be |cur_wt|, while upward ones will be |-cur_wt|. 8034 8035Of course, this subroutine will be called only in connection with others 8036that eventually draw a complete cycle, so that the sum of the edge weights 8037in each row will be zero whenever the row is displayed. 8038 8039@p procedure line_edges(@!x0,@!y0,@!x1,@!y1:scaled); 8040label done,done1; 8041var @!m0,@!n0,@!m1,@!n1:integer; {rounded and unscaled coordinates} 8042@!delx,@!dely:scaled; {the coordinate differences of the line} 8043@!yt:scaled; {smallest |y| coordinate that rounds the same as |y0|} 8044@!tx:scaled; {tentative change in |x|} 8045@!p,@!r:pointer; {list manipulation registers} 8046@!base:integer; {amount added to edge-and-weight data} 8047@!n:integer; {current row number} 8048begin n0:=round_unscaled(y0); 8049n1:=round_unscaled(y1); 8050if n0<>n1 then 8051 begin m0:=round_unscaled(x0); m1:=round_unscaled(x1); 8052 delx:=x1-x0; dely:=y1-y0; 8053 yt:=n0*unity-half_unit; y0:=y0-yt; y1:=y1-yt; 8054 if n0<n1 then @<Insert upward edges for a line@> 8055 else @<Insert downward edges for a line@>; 8056 n_rover(cur_edges):=p; n_pos(cur_edges):=n+zero_field; 8057 end; 8058end; 8059 8060@ Here we are careful to cancel any effect of rounding error. 8061 8062@<Insert upward edges for a line@>= 8063begin base:=8*m_offset(cur_edges)+min_halfword+zero_w-cur_wt; 8064if m0<=m1 then edge_prep(m0,m1,n0,n1)@+else edge_prep(m1,m0,n0,n1); 8065@<Move to row |n0|, pointed to by |p|@>; 8066y0:=unity-y0; 8067loop@+ begin r:=get_avail; link(r):=unsorted(p); unsorted(p):=r;@/ 8068 tx:=take_fraction(delx,make_fraction(y0,dely)); 8069 if ab_vs_cd(delx,y0,dely,tx)<0 then decr(tx); 8070 {now $|tx|=\lfloor|y0|\cdot|delx|/|dely|\rfloor$} 8071 info(r):=8*round_unscaled(x0+tx)+base;@/ 8072 y1:=y1-unity; 8073 if internal[tracing_edges]>0 then trace_new_edge(r,n); 8074 if y1<unity then goto done; 8075 p:=link(p); y0:=y0+unity; incr(n); 8076 end; 8077done: end 8078 8079@ @<Insert downward edges for a line@>= 8080begin base:=8*m_offset(cur_edges)+min_halfword+zero_w+cur_wt; 8081if m0<=m1 then edge_prep(m0,m1,n1,n0)@+else edge_prep(m1,m0,n1,n0); 8082decr(n0); @<Move to row |n0|, pointed to by |p|@>; 8083loop@+ begin r:=get_avail; link(r):=unsorted(p); unsorted(p):=r;@/ 8084 tx:=take_fraction(delx,make_fraction(y0,dely)); 8085 if ab_vs_cd(delx,y0,dely,tx)<0 then incr(tx); 8086 {now $|tx|=\lceil|y0|\cdot|delx|/|dely|\rceil$, since |dely<0|} 8087 info(r):=8*round_unscaled(x0-tx)+base;@/ 8088 y1:=y1+unity; 8089 if internal[tracing_edges]>0 then trace_new_edge(r,n); 8090 if y1>=0 then goto done1; 8091 p:=knil(p); y0:=y0+unity; decr(n); 8092 end; 8093done1: end 8094 8095@ @<Move to row |n0|, pointed to by |p|@>= 8096n:=n_pos(cur_edges)-zero_field; p:=n_rover(cur_edges); 8097if n<>n0 then 8098 if n<n0 then 8099 repeat incr(n); p:=link(p); 8100 until n=n0 8101 else repeat decr(n); p:=knil(p); 8102 until n=n0 8103 8104@ \MF\ inserts most of its edges into edge structures via the 8105|move_to_edges| subroutine, which uses the data stored in the |move| array 8106to specify a sequence of ``rook moves.'' The starting point |(m0,n0)| 8107and finishing point |(m1,n1)| of these moves, as seen from the standpoint 8108of the first octant, are supplied as parameters; the moves should, however, 8109be rotated into a given octant. (We're going to study octant 8110transformations in great detail later; the reader may wish to come back to 8111this part of the program after mastering the mysteries of octants.) 8112 8113The rook moves themselves are defined as follows, from a |first_octant| 8114point of view: ``Go right |move[k]| steps, then go up one, for |0<=k<n1-n0|; 8115then go right |move[n1-n0]| steps and stop.'' The sum of |move[k]| 8116for |0<=k<=n1-n0| will be equal to |m1-m0|. 8117 8118As in the |line_edges| routine, we use |+cur_wt| as the weight of 8119all downward edges and |-cur_wt| as the weight of all upward edges, 8120after the moves have been rotated to the proper octant direction. 8121 8122There are two main cases to consider: \\{fast\_case} is for moves that 8123travel in the direction of octants 1, 4, 5, and~8, while \\{slow\_case} 8124is for moves that travel toward octants 2, 3, 6, and~7. The latter directions 8125are comparatively cumbersome because they generate more upward or downward 8126edges; a curve that travels horizontally doesn't produce any edges at all, 8127but a curve that travels vertically touches lots of rows. 8128 8129@d fast_case_up=60 {for octants 1 and 4} 8130@d fast_case_down=61 {for octants 5 and 8} 8131@d slow_case_up=62 {for octants 2 and 3} 8132@d slow_case_down=63 {for octants 6 and 7} 8133 8134@p procedure move_to_edges(@!m0,@!n0,@!m1,@!n1:integer); 8135label fast_case_up,fast_case_down,slow_case_up,slow_case_down,done; 8136var @!delta:0..move_size; {extent of |move| data} 8137@!k:0..move_size; {index into |move|} 8138@!p,@!r:pointer; {list manipulation registers} 8139@!dx:integer; {change in edge-weight |info| when |x| changes by 1} 8140@!edge_and_weight:integer; {|info| to insert} 8141@!j:integer; {number of consecutive vertical moves} 8142@!n:integer; {the current row pointed to by |p|} 8143debug @!sum:integer;@+gubed@;@/ 8144begin delta:=n1-n0; 8145debug sum:=move[0]; for k:=1 to delta do sum:=sum+abs(move[k]); 8146if sum<>m1-m0 then confusion("0");@+gubed@;@/ 8147@:this can't happen 0}{\quad 0@> 8148@<Prepare for and switch to the appropriate case, based on |octant|@>; 8149fast_case_up:@<Add edges for first or fourth octants, then |goto done|@>; 8150fast_case_down:@<Add edges for fifth or eighth octants, then |goto done|@>; 8151slow_case_up:@<Add edges for second or third octants, then |goto done|@>; 8152slow_case_down:@<Add edges for sixth or seventh octants, then |goto done|@>; 8153done: n_pos(cur_edges):=n+zero_field; n_rover(cur_edges):=p; 8154end; 8155 8156@ The current octant code appears in a global variable. If, for example, 8157we have |octant=third_octant|, it means that a curve traveling in a north to 8158north-westerly direction has been rotated for the purposes of internal 8159calculations so that the |move| data travels in an east to north-easterly 8160direction. We want to unrotate as we update the edge structure. 8161 8162@<Glob...@>= 8163@!octant:first_octant..sixth_octant; {the current octant of interest} 8164 8165@ @<Prepare for and switch to the appropriate case, based on |octant|@>= 8166case octant of 8167first_octant:begin dx:=8; edge_prep(m0,m1,n0,n1); goto fast_case_up; 8168 end; 8169second_octant:begin dx:=8; edge_prep(n0,n1,m0,m1); goto slow_case_up; 8170 end; 8171third_octant:begin dx:=-8; edge_prep(-n1,-n0,m0,m1); negate(n0); 8172 goto slow_case_up; 8173 end; 8174fourth_octant:begin dx:=-8; edge_prep(-m1,-m0,n0,n1); negate(m0); 8175 goto fast_case_up; 8176 end; 8177fifth_octant:begin dx:=-8; edge_prep(-m1,-m0,-n1,-n0); negate(m0); 8178 goto fast_case_down; 8179 end; 8180sixth_octant:begin dx:=-8; edge_prep(-n1,-n0,-m1,-m0); negate(n0); 8181 goto slow_case_down; 8182 end; 8183seventh_octant:begin dx:=8; edge_prep(n0,n1,-m1,-m0); goto slow_case_down; 8184 end; 8185eighth_octant:begin dx:=8; edge_prep(m0,m1,-n1,-n0); goto fast_case_down; 8186 end; 8187end; {there are only eight octants} 8188 8189@ @<Add edges for first or fourth octants, then |goto done|@>= 8190@<Move to row |n0|, pointed to by |p|@>; 8191if delta>0 then 8192 begin k:=0; 8193 edge_and_weight:=8*(m0+m_offset(cur_edges))+min_halfword+zero_w-cur_wt; 8194 repeat edge_and_weight:=edge_and_weight+dx*move[k]; 8195 fast_get_avail(r); link(r):=unsorted(p); info(r):=edge_and_weight; 8196 if internal[tracing_edges]>0 then trace_new_edge(r,n); 8197 unsorted(p):=r; p:=link(p); incr(k); incr(n); 8198 until k=delta; 8199 end; 8200goto done 8201 8202@ @<Add edges for fifth or eighth octants, then |goto done|@>= 8203n0:=-n0-1; @<Move to row |n0|, pointed to by |p|@>; 8204if delta>0 then 8205 begin k:=0; 8206 edge_and_weight:=8*(m0+m_offset(cur_edges))+min_halfword+zero_w+cur_wt; 8207 repeat edge_and_weight:=edge_and_weight+dx*move[k]; 8208 fast_get_avail(r); link(r):=unsorted(p); info(r):=edge_and_weight; 8209 if internal[tracing_edges]>0 then trace_new_edge(r,n); 8210 unsorted(p):=r; p:=knil(p); incr(k); decr(n); 8211 until k=delta; 8212 end; 8213goto done 8214 8215@ @<Add edges for second or third octants, then |goto done|@>= 8216edge_and_weight:=8*(n0+m_offset(cur_edges))+min_halfword+zero_w-cur_wt; 8217n0:=m0; k:=0; @<Move to row |n0|, pointed to by |p|@>; 8218repeat j:=move[k]; 8219while j>0 do 8220 begin fast_get_avail(r); link(r):=unsorted(p); info(r):=edge_and_weight; 8221 if internal[tracing_edges]>0 then trace_new_edge(r,n); 8222 unsorted(p):=r; p:=link(p); decr(j); incr(n); 8223 end; 8224edge_and_weight:=edge_and_weight+dx; incr(k); 8225until k>delta; 8226goto done 8227 8228@ @<Add edges for sixth or seventh octants, then |goto done|@>= 8229edge_and_weight:=8*(n0+m_offset(cur_edges))+min_halfword+zero_w+cur_wt; 8230n0:=-m0-1; k:=0; @<Move to row |n0|, pointed to by |p|@>; 8231repeat j:=move[k]; 8232while j>0 do 8233 begin fast_get_avail(r); link(r):=unsorted(p); info(r):=edge_and_weight; 8234 if internal[tracing_edges]>0 then trace_new_edge(r,n); 8235 unsorted(p):=r; p:=knil(p); decr(j); decr(n); 8236 end; 8237edge_and_weight:=edge_and_weight+dx; incr(k); 8238until k>delta; 8239goto done 8240 8241@ All the hard work of building an edge structure is undone by the following 8242subroutine. 8243 8244@<Declare the recycling subroutines@>= 8245procedure toss_edges(@!h:pointer); 8246var @!p,@!q:pointer; {for list manipulation} 8247begin q:=link(h); 8248while q<>h do 8249 begin flush_list(sorted(q)); 8250 if unsorted(q)>void then flush_list(unsorted(q)); 8251 p:=q; q:=link(q); free_node(p,row_node_size); 8252 end; 8253free_node(h,edge_header_size); 8254end; 8255 8256@* \[21] Subdivision into octants. 8257When \MF\ digitizes a path, it reduces the problem to the special 8258case of paths that travel in ``first octant'' directions; i.e., 8259each cubic $z(t)=\bigl(x(t),y(t)\bigr)$ being digitized will have the property 8260that $0\L y'(t)\L x'(t)$. This assumption makes digitizing simpler 8261and faster than if the direction of motion has to be tested repeatedly. 8262 8263When $z(t)$ is cubic, $x'(t)$ and $y'(t)$ are quadratic, hence the four 8264polynomials $x'(t)$, $y'(t)$, $x'(t)-y'(t)$, and $x'(t)+y'(t)$ cross 8265through~0 at most twice each. If we subdivide the given cubic at these 8266places, we get at most nine subintervals in each of which 8267$x'(t)$, $y'(t)$, $x'(t)-y'(t)$, and $x'(t)+y'(t)$ all have a constant 8268sign. The curve can be transformed in each of these subintervals so that 8269it travels entirely in first octant directions, if we reflect $x\swap-x$, 8270$y\swap-y$, and/or $x\swap y$ as necessary. (Incidentally, it can be 8271shown that a cubic such that $x'(t)=16(2t-1)^2+2(2t-1)-1$ and 8272$y'(t)=8(2t-1)^2+4(2t-1)$ does indeed split into nine subintervals.) 8273 8274@ The transformation that rotates coordinates, so that first octant motion 8275can be assumed, is defined by the |skew| subroutine, which sets global 8276variables |cur_x| and |cur_y| to the values that are appropriate in a 8277given octant. (Octants are encoded as they were in the |n_arg| subroutine.) 8278 8279This transformation is ``skewed'' by replacing |(x,y)| by |(x-y,y)|, 8280once first octant motion has been established. It turns out that 8281skewed coordinates are somewhat better to work with when curves are 8282actually digitized. 8283 8284@d set_two_end(#)==cur_y:=#;@+end 8285@d set_two(#)==begin cur_x:=#; set_two_end 8286 8287@p procedure skew(@!x,@!y:scaled;@!octant:small_number); 8288begin case octant of 8289first_octant: set_two(x-y)(y); 8290second_octant: set_two(y-x)(x); 8291third_octant: set_two(y+x)(-x); 8292fourth_octant: set_two(-x-y)(y); 8293fifth_octant: set_two(-x+y)(-y); 8294sixth_octant: set_two(-y+x)(-x); 8295seventh_octant: set_two(-y-x)(x); 8296eighth_octant: set_two(x+y)(-y); 8297end; {there are no other cases} 8298end; 8299 8300@ Conversely, the following subroutine sets |cur_x| and 8301|cur_y| to the original coordinate values of a point, given an octant 8302code and the point's coordinates |(x,y)| after they have been mapped into 8303the first octant and skewed. 8304 8305@<Declare subroutines for printing expressions@>= 8306procedure unskew(@!x,@!y:scaled;@!octant:small_number); 8307begin case octant of 8308first_octant: set_two(x+y)(y); 8309second_octant: set_two(y)(x+y); 8310third_octant: set_two(-y)(x+y); 8311fourth_octant: set_two(-x-y)(y); 8312fifth_octant: set_two(-x-y)(-y); 8313sixth_octant: set_two(-y)(-x-y); 8314seventh_octant: set_two(y)(-x-y); 8315eighth_octant: set_two(x+y)(-y); 8316end; {there are no other cases} 8317end; 8318 8319@ @<Glob...@>= 8320@!cur_x,@!cur_y:scaled; 8321 {outputs of |skew|, |unskew|, and a few other routines} 8322 8323@ The conversion to skewed and rotated coordinates takes place in 8324stages, and at one point in the transformation we will have negated the 8325$x$ and/or $y$ coordinates so as to make curves travel in the first 8326{\sl quadrant}. At this point the relevant ``octant'' code will be 8327either |first_octant| (when no transformation has been done), 8328or |fourth_octant=first_octant+negate_x| (when $x$ has been negated), 8329or |fifth_octant=first_octant+negate_x+negate_y| (when both have been 8330negated), or |eighth_octant=first_octant+negate_y| (when $y$ has been 8331negated). The |abnegate| routine is sometimes needed to convert 8332from one of these transformations to another. 8333 8334@p procedure abnegate(@!x,@!y:scaled; 8335 @!octant_before,@!octant_after:small_number); 8336begin if odd(octant_before)=odd(octant_after) then cur_x:=x 8337 else cur_x:=-x; 8338if (octant_before>negate_y)=(octant_after>negate_y) then cur_y:=y 8339 else cur_y:=-y; 8340end; 8341 8342@ Now here's a subroutine that's handy for subdivision: Given a 8343quadratic polynomial $B(a,b,c;t)$, the |crossing_point| function 8344returns the unique |fraction| value |t| between 0 and~1 at which 8345$B(a,b,c;t)$ changes from positive to negative, or returns 8346|t=fraction_one+1| if no such value exists. If |a<0| (so that $B(a,b,c;t)$ 8347is already negative at |t=0|), |crossing_point| returns the value zero. 8348 8349@d no_crossing==begin crossing_point:=fraction_one+1; return; 8350 end 8351@d one_crossing==begin crossing_point:=fraction_one; return; 8352 end 8353@d zero_crossing==begin crossing_point:=0; return; 8354 end 8355 8356@p function crossing_point(@!a,@!b,@!c:integer):fraction; 8357label exit; 8358var @!d:integer; {recursive counter} 8359@!x,@!xx,@!x0,@!x1,@!x2:integer; {temporary registers for bisection} 8360begin if a<0 then zero_crossing; 8361if c>=0 then 8362 begin if b>=0 then 8363 if c>0 then no_crossing 8364 else if (a=0)and(b=0) then no_crossing 8365 else one_crossing; 8366 if a=0 then zero_crossing; 8367 end 8368else if a=0 then if b<=0 then zero_crossing; 8369@<Use bisection to find the crossing point, if one exists@>; 8370exit:end; 8371 8372@ The general bisection method is quite simple when $n=2$, hence 8373|crossing_point| does not take much time. At each stage in the 8374recursion we have a subinterval defined by |l| and~|j| such that 8375$B(a,b,c;2^{-l}(j+t))=B(x_0,x_1,x_2;t)$, and we want to ``zero in'' on 8376the subinterval where $x_0\G0$ and $\min(x_1,x_2)<0$. 8377 8378It is convenient for purposes of calculation to combine the values 8379of |l| and~|j| in a single variable $d=2^l+j$, because the operation 8380of bisection then corresponds simply to doubling $d$ and possibly 8381adding~1. Furthermore it proves to be convenient to modify 8382our previous conventions for bisection slightly, maintaining the 8383variables $X_0=2^lx_0$, $X_1=2^l(x_0-x_1)$, and $X_2=2^l(x_1-x_2)$. 8384With these variables the conditions $x_0\ge0$ and $\min(x_1,x_2)<0$ are 8385equivalent to $\max(X_1,X_1+X_2)>X_0\ge0$. 8386 8387The following code maintains the invariant relations 8388$0\L|x0|<\max(|x1|,|x1|+|x2|)$, 8389$\vert|x1|\vert<2^{30}$, $\vert|x2|\vert<2^{30}$; 8390it has been constructed in such a way that no arithmetic overflow 8391will occur if the inputs satisfy 8392$a<2^{30}$, $\vert a-b\vert<2^{30}$, and $\vert b-c\vert<2^{30}$. 8393 8394@<Use bisection to find the crossing point...@>= 8395d:=1; x0:=a; x1:=a-b; x2:=b-c; 8396repeat x:=half(x1+x2); 8397if x1-x0>x0 then 8398 begin x2:=x; double(x0); double(d); 8399 end 8400else begin xx:=x1+x-x0; 8401 if xx>x0 then 8402 begin x2:=x; double(x0); double(d); 8403 end 8404 else begin x0:=x0-xx; 8405 if x<=x0 then if x+x2<=x0 then no_crossing; 8406 x1:=x; d:=d+d+1; 8407 end; 8408 end; 8409until d>=fraction_one; 8410crossing_point:=d-fraction_one 8411 8412@ Octant subdivision is applied only to cycles, i.e., to closed paths. 8413A ``cycle spec'' is a data structure that contains specifications of 8414@!@^cycle spec@> 8415cubic curves and octant mappings for the cycle that has been subdivided 8416into segments belonging to single octants. It is composed entirely of 8417knot nodes, similar to those in the representation of paths; but the 8418|explicit| type indications have been replaced by positive numbers 8419that give further information. Additional |endpoint| data is also 8420inserted at the octant boundaries. 8421 8422Recall that a cubic polynomial is represented by four control points 8423that appear in adjacent nodes |p| and~|q| of a knot list. The |x|~coordinates 8424are |x_coord(p)|, |right_x(p)|, |left_x(q)|, and |x_coord(q)|; the 8425|y|~coordinates are similar. We shall call this ``the cubic following~|p|'' 8426or ``the cubic between |p| and~|q|'' or ``the cubic preceding~|q|.'' 8427 8428Cycle specs are circular lists of cubic curves mixed with octant 8429boundaries. Like cubics, the octant boundaries are represented in 8430consecutive knot nodes |p| and~|q|. In such cases |right_type(p)= 8431left_type(q)=endpoint|, and the fields |right_x(p)|, |right_y(p)|, 8432|left_x(q)|, and |left_y(q)| are replaced by other fields called 8433|right_octant(p)|, |right_transition(p)|, |left_octant(q)|, and 8434|left_transition(q)|, respectively. For example, when the curve direction 8435moves from the third octant to the fourth octant, the boundary nodes say 8436|right_octant(p)=third_octant|, |left_octant(q)=fourth_octant|, 8437and |right_transition(p)=left_transition(q)=diagonal|. A |diagonal| 8438transition occurs when moving between octants 1~\AM~2, 3~\AM~4, 5~\AM~6, or 84397~\AM~8; an |axis| transition occurs when moving between octants 8~\AM~1, 84402~\AM~3, 4~\AM~5, 6~\AM~7. (Such transition information is redundant 8441but convenient.) Fields |x_coord(p)| and |y_coord(p)| will contain 8442coordinates of the transition point after rotation from third octant 8443to first octant; i.e., if the true coordinates are $(x,y)$, the 8444coordinates $(y,-x)$ will appear in node~|p|. Similarly, a fourth-octant 8445transformation will have been applied after the transition, so 8446we will have |x_coord(q)=@t$-x$@>| and |y_coord(q)=y|. 8447 8448The cubic between |p| and |q| will contain positive numbers in the 8449fields |right_type(p)| and |left_type(q)|; this makes cubics 8450distinguishable from octant boundaries, because |endpoint=0|. 8451The value of |right_type(p)| will be the current octant code, 8452during the time that cycle specs are being constructed; it will 8453refer later to a pen offset position, if the envelope of a cycle is 8454being computed. A cubic that comes from some subinterval of the $k$th 8455step in the original cyclic path will have |left_type(q)=k|. 8456 8457@d right_octant==right_x {the octant code before a transition} 8458@d left_octant==left_x {the octant after a transition} 8459@d right_transition==right_y {the type of transition} 8460@d left_transition==left_y {ditto, either |axis| or |diagonal|} 8461@d axis=0 {a transition across the $x'$- or $y'$-axis} 8462@d diagonal=1 {a transition where $y'=\pm x'$} 8463 8464@ Here's a routine that prints a cycle spec in symbolic form, so that it 8465is possible to see what subdivision has been made. The point coordinates 8466are converted back from \MF's internal ``rotated'' form to the external 8467``true'' form. The global variable~|cur_spec| should point to a knot just 8468after the beginning of an octant boundary, i.e., such that 8469|left_type(cur_spec)=endpoint|. 8470 8471@d print_two_true(#)==unskew(#,octant); print_two(cur_x,cur_y) 8472 8473@p procedure print_spec(@!s:str_number); 8474label not_found,done; 8475var @!p,@!q:pointer; {for list traversal} 8476@!octant:small_number; {the current octant code} 8477begin print_diagnostic("Cycle spec",s,true); 8478@.Cycle spec at line...@> 8479p:=cur_spec; octant:=left_octant(p); print_ln; 8480print_two_true(x_coord(cur_spec),y_coord(cur_spec)); 8481print(" % beginning in octant `"); 8482loop@+ begin print(octant_dir[octant]); print_char("'"); 8483 loop@+ begin q:=link(p); 8484 if right_type(p)=endpoint then goto not_found; 8485 @<Print the cubic between |p| and |q|@>; 8486 p:=q; 8487 end; 8488not_found: if q=cur_spec then goto done; 8489 p:=q; octant:=left_octant(p); print_nl("% entering octant `"); 8490 end; 8491@.entering the nth octant@> 8492done: print_nl(" & cycle"); end_diagnostic(true); 8493end; 8494 8495@ Symbolic octant direction names are kept in the |octant_dir| array. 8496 8497@<Glob...@>= 8498@!octant_dir:array[first_octant..sixth_octant] of str_number; 8499 8500@ @<Set init...@>= 8501octant_dir[first_octant]:="ENE"; 8502octant_dir[second_octant]:="NNE"; 8503octant_dir[third_octant]:="NNW"; 8504octant_dir[fourth_octant]:="WNW"; 8505octant_dir[fifth_octant]:="WSW"; 8506octant_dir[sixth_octant]:="SSW"; 8507octant_dir[seventh_octant]:="SSE"; 8508octant_dir[eighth_octant]:="ESE"; 8509 8510@ @<Print the cubic between...@>= 8511begin print_nl(" ..controls "); 8512print_two_true(right_x(p),right_y(p)); 8513print(" and "); 8514print_two_true(left_x(q),left_y(q)); 8515print_nl(" .."); 8516print_two_true(x_coord(q),y_coord(q)); 8517print(" % segment "); print_int(left_type(q)-1); 8518end 8519 8520@ A much more compact version of a spec is printed to help users identify 8521``strange paths.'' 8522 8523@p procedure print_strange(@!s:str_number); 8524var @!p:pointer; {for list traversal} 8525@!f:pointer; {starting point in the cycle} 8526@!q:pointer; {octant boundary to be printed} 8527@!t:integer; {segment number, plus 1} 8528begin if interaction=error_stop_mode then wake_up_terminal; 8529print_nl(">"); 8530@.>\relax@> 8531@<Find the starting point, |f|@>; 8532@<Determine the octant boundary |q| that precedes |f|@>; 8533t:=0; 8534repeat if left_type(p)<>endpoint then 8535 begin if left_type(p)<>t then 8536 begin t:=left_type(p); print_char(" "); print_int(t-1); 8537 end; 8538 if q<>null then 8539 begin @<Print the turns, if any, that start at |q|, and advance |q|@>; 8540 print_char(" "); print(octant_dir[left_octant(q)]); q:=null; 8541 end; 8542 end 8543else if q=null then q:=p; 8544p:=link(p); 8545until p=f; 8546print_char(" "); print_int(left_type(p)-1); 8547if q<>null then @<Print the turns...@>; 8548print_err(s); 8549end; 8550 8551@ If the segment numbers on the cycle are $t_1$, $t_2$, \dots, $t_m$, 8552and if |m<=max_quarterword|, 8553we have $t_{k-1}\L t_k$ except for at most one value of~$k$. If there are 8554no exceptions, $f$ will point to $t_1$; otherwise it will point to the 8555exceptional~$t_k$. 8556 8557There is at least one segment number (i.e., we always have $m>0$), because 8558|print_strange| is never called upon to display an entirely ``dead'' cycle. 8559 8560@<Find the starting point, |f|@>= 8561p:=cur_spec; t:=max_quarterword+1; 8562repeat p:=link(p); 8563if left_type(p)<>endpoint then 8564 begin if left_type(p)<t then f:=p; 8565 t:=left_type(p); 8566 end; 8567until p=cur_spec 8568 8569@ @<Determine the octant boundary...@>= 8570p:=cur_spec; q:=p; 8571repeat p:=link(p); 8572if left_type(p)=endpoint then q:=p; 8573until p=f 8574 8575@ When two octant boundaries are adjacent, the path is simply changing direction 8576without moving. Such octant directions are shown in parentheses. 8577 8578@<Print the turns...@>= 8579if left_type(link(q))=endpoint then 8580 begin print(" ("); print(octant_dir[left_octant(q)]); q:=link(q); 8581 while left_type(link(q))=endpoint do 8582 begin print_char(" "); print(octant_dir[left_octant(q)]); q:=link(q); 8583 end; 8584 print_char(")"); 8585 end 8586 8587@ The |make_spec| routine is what subdivides paths into octants: 8588Given a pointer |cur_spec| to a cyclic path, |make_spec| mungs the path data 8589and returns a pointer to the corresponding cyclic spec. 8590All ``dead'' cubics (i.e., cubics that don't move at all from 8591their starting points) will have been removed from the result. 8592@!@^dead cubics@> 8593 8594The idea of |make_spec| is fairly simple: Each cubic is first 8595subdivided, if necessary, into pieces belonging to single octants; 8596then the octant boundaries are inserted. But some of the details of 8597this transformation are not quite obvious. 8598 8599If |autorounding>0|, the path will be adjusted so that critical tangent 8600directions occur at ``good'' points with respect to the pen called |cur_pen|. 8601 8602The resulting spec will have all |x| and |y| coordinates at most 8603$2^{28}-|half_unit|-1-|safety_margin|$ in absolute value. The pointer 8604that is returned will start some octant, as required by |print_spec|. 8605 8606@p @t\4@>@<Declare subroutines needed by |make_spec|@>@; 8607function make_spec(@!h:pointer; 8608 @!safety_margin:scaled;@!tracing:integer):pointer; 8609 {converts a path to a cycle spec} 8610label continue,done; 8611var @!p,@!q,@!r,@!s:pointer; {for traversing the lists} 8612@!k:integer; {serial number of path segment, or octant code} 8613@!chopped:integer; {positive if data truncated, 8614 negative if data dangerously large} 8615@<Other local variables for |make_spec|@>@; 8616begin cur_spec:=h; 8617if tracing>0 then 8618 print_path(cur_spec,", before subdivision into octants",true); 8619max_allowed:=fraction_one-half_unit-1-safety_margin; 8620@<Truncate the values of all coordinates that exceed |max_allowed|, and stamp 8621 segment numbers in each |left_type| field@>; 8622quadrant_subdivide; {subdivide each cubic into pieces belonging to quadrants} 8623if (internal[autorounding]>0)and(chopped=0) then xy_round; 8624octant_subdivide; {complete the subdivision} 8625if (internal[autorounding]>unity)and(chopped=0) then diag_round; 8626@<Remove dead cubics@>; 8627@<Insert octant boundaries and compute the turning number@>; 8628while left_type(cur_spec)<>endpoint do cur_spec:=link(cur_spec); 8629if tracing>0 then 8630 if (internal[autorounding]<=0)or(chopped<>0) then 8631 print_spec(", after subdivision") 8632 else if internal[autorounding]>unity then 8633 print_spec(", after subdivision and double autorounding") 8634 else print_spec(", after subdivision and autorounding"); 8635make_spec:=cur_spec; 8636end; 8637 8638@ The |make_spec| routine has an interesting side effect, namely to set 8639the global variable |turning_number| to the number of times the tangent 8640vector of the given cyclic path winds around the origin. 8641 8642Another global variable |cur_spec| points to the specification as it is 8643being made, since several subroutines must go to work on it. 8644 8645And there are two global variables that affect the rounding 8646decisions, as we'll see later; they are called |cur_pen| and |cur_path_type|. 8647The latter will be |double_path_code| if |make_spec| is being 8648applied to a double path. 8649 8650@d double_path_code=0 {command modifier for `\&{doublepath}'} 8651@d contour_code=1 {command modifier for `\&{contour}'} 8652@d also_code=2 {command modifier for `\&{also}'} 8653 8654@<Glob...@>= 8655@!cur_spec:pointer; {the principal output of |make_spec|} 8656@!turning_number:integer; {another output of |make_spec|} 8657@!cur_pen:pointer; {an implicit input of |make_spec|, used in autorounding} 8658@!cur_path_type:double_path_code..contour_code; {likewise} 8659@!max_allowed:scaled; {coordinates must be at most this big} 8660 8661@ First we do a simple preprocessing step. The segment numbers inserted 8662here will propagate to all descendants of cubics that are split into 8663subintervals. These numbers must be nonzero, but otherwise they are 8664present merely for diagnostic purposes. The cubic from |p| to~|q| 8665that represents ``time interval'' |(t-1)..t| usually has |left_type(q)=t|, 8666except when |t| is too large to be stored in a quarterword. 8667 8668@d procrustes(#)==@+if abs(#)>=dmax then 8669 if abs(#)>max_allowed then 8670 begin chopped:=1; 8671 if #>0 then #:=max_allowed@+else #:=-max_allowed; 8672 end 8673 else if chopped=0 then chopped:=-1 8674 8675@<Truncate the values of all coordinates that exceed...@>= 8676p:=cur_spec; k:=1; chopped:=0; dmax:=half(max_allowed); 8677repeat procrustes(left_x(p)); procrustes(left_y(p)); 8678procrustes(x_coord(p)); procrustes(y_coord(p)); 8679procrustes(right_x(p)); procrustes(right_y(p));@/ 8680p:=link(p); left_type(p):=k; 8681if k<max_quarterword then incr(k)@+else k:=1; 8682until p=cur_spec; 8683if chopped>0 then 8684 begin print_err("Curve out of range"); 8685@.Curve out of range@> 8686 help4("At least one of the coordinates in the path I'm about to")@/ 8687 ("digitize was really huge (potentially bigger than 4095).")@/ 8688 ("So I've cut it back to the maximum size.")@/ 8689 ("The results will probably be pretty wild."); 8690 put_get_error; 8691 end 8692 8693@ We may need to get rid of constant ``dead'' cubics that clutter up 8694the data structure and interfere with autorounding. 8695 8696@<Declare subroutines needed by |make_spec|@>= 8697procedure remove_cubic(@!p:pointer); {removes the cubic following~|p|} 8698var @!q:pointer; {the node that disappears} 8699begin q:=link(p); right_type(p):=right_type(q); link(p):=link(q);@/ 8700x_coord(p):=x_coord(q); y_coord(p):=y_coord(q);@/ 8701right_x(p):=right_x(q); right_y(p):=right_y(q);@/ 8702free_node(q,knot_node_size); 8703end; 8704 8705@ The subdivision process proceeds by first swapping $x\swap-x$, if 8706necessary, to ensure that $x'\G0$; then swapping $y\swap-y$, if necessary, 8707to ensure that $y'\G0$; and finally swapping $x\swap y$, if necessary, 8708to ensure that $x'\G y'$. 8709 8710Recall that the octant codes have been defined in such a way that, for 8711example, |third_octant=first_octant+negate_x+switch_x_and_y|. The program 8712uses the fact that |negate_x<negate_y<switch_x_and_y| to handle ``double 8713negation'': If |c| is an octant code that possibly involves |negate_x| 8714and/or |negate_y|, but not |switch_x_and_y|, then negating~|y| changes~|c| 8715either to |c+negate_y| or |c-negate_y|, depending on whether 8716|c<=negate_y| or |c>negate_y|. Octant codes are always greater than zero. 8717 8718The first step is to subdivide on |x| and |y| only, so that horizontal 8719and vertical autorounding can be done before we compare $x'$ to $y'$. 8720 8721@<Declare subroutines needed by |make_spec|@>= 8722@t\4@>@<Declare the procedure called |split_cubic|@>@; 8723procedure quadrant_subdivide; 8724label continue,exit; 8725var @!p,@!q,@!r,@!s,@!pp,@!qq:pointer; {for traversing the lists} 8726@!first_x,@!first_y:scaled; {unnegated coordinates of node |cur_spec|} 8727@!del1,@!del2,@!del3,@!del,@!dmax:scaled; {proportional to the control 8728 points of a quadratic derived from a cubic} 8729@!t:fraction; {where a quadratic crosses zero} 8730@!dest_x,@!dest_y:scaled; {final values of |x| and |y| in the current cubic} 8731@!constant_x:boolean; {is |x| constant between |p| and |q|?} 8732begin p:=cur_spec; first_x:=x_coord(cur_spec); first_y:=y_coord(cur_spec); 8733repeat continue: q:=link(p); 8734@<Subdivide the cubic between |p| and |q| so that the results travel 8735 toward the right halfplane@>; 8736@<Subdivide all cubics between |p| and |q| so that the results travel 8737 toward the first quadrant; but |return| or |goto continue| if the 8738 cubic from |p| to |q| was dead@>; 8739p:=q; 8740until p=cur_spec; 8741exit:end; 8742 8743@ All three subdivision processes are similar, so it's possible to 8744get the general idea by studying the first one (which is the simplest). 8745The calculation makes use of the fact that the derivatives of 8746Bernshte{\u\i}n polynomials satisfy 8747$B'(z_0,z_1,\ldots,z_n;t)=nB(z_1-z_0,\ldots,z_n-z_{n-1};t)$. 8748 8749When this routine begins, |right_type(p)| is |explicit|; we should 8750set |right_type(p):=first_octant|. However, no assignment is made, 8751because |explicit=first_octant|. The author apologizes for using 8752such trickery here; it is really hard to do redundant computations 8753just for the sake of purity. 8754 8755@<Subdivide the cubic between |p| and |q| so that the results travel 8756 toward the right halfplane...@>= 8757if q=cur_spec then 8758 begin dest_x:=first_x; dest_y:=first_y; 8759 end 8760else begin dest_x:=x_coord(q); dest_y:=y_coord(q); 8761 end; 8762del1:=right_x(p)-x_coord(p); del2:=left_x(q)-right_x(p); 8763del3:=dest_x-left_x(q); 8764@<Scale up |del1|, |del2|, and |del3| for greater accuracy; 8765 also set |del| to the first nonzero element of |(del1,del2,del3)|@>; 8766if del=0 then constant_x:=true 8767else begin constant_x:=false; 8768 if del<0 then @<Complement the |x| coordinates of the 8769 cubic between |p| and~|q|@>; 8770 t:=crossing_point(del1,del2,del3); 8771 if t<fraction_one then 8772 @<Subdivide the cubic with respect to $x'$, possibly twice@>; 8773 end 8774 8775@ If |del1=del2=del3=0|, it's impossible to obey the title of this 8776section. We just set |del=0| in that case. 8777@^inner loop@> 8778 8779@<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>= 8780if del1<>0 then del:=del1 8781else if del2<>0 then del:=del2 8782else del:=del3; 8783if del<>0 then 8784 begin dmax:=abs(del1); 8785 if abs(del2)>dmax then dmax:=abs(del2); 8786 if abs(del3)>dmax then dmax:=abs(del3); 8787 while dmax<fraction_half do 8788 begin double(dmax); double(del1); double(del2); double(del3); 8789 end; 8790 end 8791 8792@ During the subdivision phases of |make_spec|, the |x_coord| and |y_coord| 8793fields of node~|q| are not transformed to agree with the octant 8794stated in |right_type(p)|; they remain consistent with |right_type(q)|. 8795But |left_x(q)| and |left_y(q)| are governed by |right_type(p)|. 8796 8797@<Complement the |x| coordinates...@>= 8798begin negate(x_coord(p)); negate(right_x(p)); 8799negate(left_x(q));@/ 8800negate(del1); negate(del2); negate(del3);@/ 8801negate(dest_x); 8802right_type(p):=first_octant+negate_x; 8803end 8804 8805@ When a cubic is split at a |fraction| value |t|, we obtain two cubics 8806whose B\'ezier control points are obtained by a generalization of the 8807bisection process: The formula 8808`$z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$' becomes 8809`$z_k^{(j+1)}=t[z_k^{(j)},z\k^{(j)}]$'. 8810 8811It is convenient to define a \.{WEB} macro |t_of_the_way| such that 8812|t_of_the_way(a)(b)| expands to |a-(a-b)*t|, i.e., to |t[a,b]|. 8813 8814If |0<=t<=1|, the quantity |t[a,b]| is always between |a| and~|b|, even in 8815the presence of rounding errors. Our subroutines 8816also obey the identity |t[a,b]+t[b,a]=a+b|. 8817 8818@d t_of_the_way_end(#)==#,t@=)@> 8819@d t_of_the_way(#)==#-take_fraction@=(@>#-t_of_the_way_end 8820 8821@<Declare the procedure called |split_cubic|@>= 8822procedure split_cubic(@!p:pointer;@!t:fraction; 8823 @!xq,@!yq:scaled); {splits the cubic after |p|} 8824var @!v:scaled; {an intermediate value} 8825@!q,@!r:pointer; {for list manipulation} 8826begin q:=link(p); r:=get_node(knot_node_size); link(p):=r; link(r):=q;@/ 8827left_type(r):=left_type(q); right_type(r):=right_type(p);@# 8828v:=t_of_the_way(right_x(p))(left_x(q)); 8829right_x(p):=t_of_the_way(x_coord(p))(right_x(p)); 8830left_x(q):=t_of_the_way(left_x(q))(xq); 8831left_x(r):=t_of_the_way(right_x(p))(v); 8832right_x(r):=t_of_the_way(v)(left_x(q)); 8833x_coord(r):=t_of_the_way(left_x(r))(right_x(r));@# 8834v:=t_of_the_way(right_y(p))(left_y(q)); 8835right_y(p):=t_of_the_way(y_coord(p))(right_y(p)); 8836left_y(q):=t_of_the_way(left_y(q))(yq); 8837left_y(r):=t_of_the_way(right_y(p))(v); 8838right_y(r):=t_of_the_way(v)(left_y(q)); 8839y_coord(r):=t_of_the_way(left_y(r))(right_y(r)); 8840end; 8841 8842@ Since $x'(t)$ is a quadratic equation, it can cross through zero 8843at~most twice. When it does cross zero, we make doubly sure that the 8844derivative is really zero at the splitting point, in case rounding errors 8845have caused the split cubic to have an apparently nonzero derivative. 8846We also make sure that the split cubic is monotonic. 8847 8848@<Subdivide the cubic with respect to $x'$, possibly twice@>= 8849begin split_cubic(p,t,dest_x,dest_y); r:=link(p); 8850if right_type(r)>negate_x then right_type(r):=first_octant 8851else right_type(r):=first_octant+negate_x; 8852if x_coord(r)<x_coord(p) then x_coord(r):=x_coord(p); 8853left_x(r):=x_coord(r); 8854if right_x(p)>x_coord(r) then right_x(p):=x_coord(r); 8855 {we always have |x_coord(p)<=right_x(p)|} 8856negate(x_coord(r)); right_x(r):=x_coord(r); 8857negate(left_x(q)); negate(dest_x);@/ 8858del2:=t_of_the_way(del2)(del3); 8859 {now |0,del2,del3| represent $x'$ on the remaining interval} 8860if del2>0 then del2:=0; 8861t:=crossing_point(0,-del2,-del3); 8862if t<fraction_one then @<Subdivide the cubic a second time 8863 with respect to $x'$@> 8864else begin if x_coord(r)>dest_x then 8865 begin x_coord(r):=dest_x; left_x(r):=-x_coord(r); right_x(r):=x_coord(r); 8866 end; 8867 if left_x(q)>dest_x then left_x(q):=dest_x 8868 else if left_x(q)<x_coord(r) then left_x(q):=x_coord(r); 8869 end; 8870end 8871 8872@ @<Subdivide the cubic a second time with respect to $x'$@>= 8873begin split_cubic(r,t,dest_x,dest_y); s:=link(r); 8874if x_coord(s)<dest_x then x_coord(s):=dest_x; 8875if x_coord(s)<x_coord(r) then x_coord(s):=x_coord(r); 8876right_type(s):=right_type(p); 8877left_x(s):=x_coord(s); {now |x_coord(r)=right_x(r)<=left_x(s)|} 8878if left_x(q)<dest_x then left_x(q):=-dest_x 8879else if left_x(q)>x_coord(s) then left_x(q):=-x_coord(s) 8880else negate(left_x(q)); 8881negate(x_coord(s)); right_x(s):=x_coord(s); 8882end 8883 8884@ The process of subdivision with respect to $y'$ is like that with respect 8885to~$x'$, with the slight additional complication that two or three cubics 8886might now appear between |p| and~|q|. 8887 8888@<Subdivide all cubics between |p| and |q| so that the results travel 8889 toward the first quadrant...@>= 8890pp:=p; 8891repeat qq:=link(pp); 8892abnegate(x_coord(qq),y_coord(qq),right_type(qq),right_type(pp)); 8893dest_x:=cur_x; dest_y:=cur_y;@/ 8894del1:=right_y(pp)-y_coord(pp); del2:=left_y(qq)-right_y(pp); 8895del3:=dest_y-left_y(qq); 8896@<Scale up |del1|, |del2|, and |del3| for greater accuracy; 8897 also set |del| to the first nonzero element of |(del1,del2,del3)|@>; 8898if del<>0 then {they weren't all zero} 8899 begin if del<0 then @<Complement the |y| coordinates of the 8900 cubic between |pp| and~|qq|@>; 8901 t:=crossing_point(del1,del2,del3); 8902 if t<fraction_one then 8903 @<Subdivide the cubic with respect to $y'$, possibly twice@>; 8904 end 8905else @<Do any special actions needed when |y| is constant; 8906 |return| or |goto continue| if a dead cubic from |p| to |q| is removed@>; 8907pp:=qq; 8908until pp=q; 8909if constant_x then @<Correct the octant code in segments with decreasing |y|@> 8910 8911@ @<Complement the |y| coordinates...@>= 8912begin negate(y_coord(pp)); negate(right_y(pp)); 8913negate(left_y(qq));@/ 8914negate(del1); negate(del2); negate(del3);@/ 8915negate(dest_y); 8916right_type(pp):=right_type(pp)+negate_y; 8917end 8918 8919@ @<Subdivide the cubic with respect to $y'$, possibly twice@>= 8920begin split_cubic(pp,t,dest_x,dest_y); r:=link(pp); 8921if right_type(r)>negate_y then right_type(r):=right_type(r)-negate_y 8922else right_type(r):=right_type(r)+negate_y; 8923if y_coord(r)<y_coord(pp) then y_coord(r):=y_coord(pp); 8924left_y(r):=y_coord(r); 8925if right_y(pp)>y_coord(r) then right_y(pp):=y_coord(r); 8926 {we always have |y_coord(pp)<=right_y(pp)|} 8927negate(y_coord(r)); right_y(r):=y_coord(r); 8928negate(left_y(qq)); negate(dest_y);@/ 8929if x_coord(r)<x_coord(pp) then x_coord(r):=x_coord(pp) 8930else if x_coord(r)>dest_x then x_coord(r):=dest_x; 8931if left_x(r)>x_coord(r) then 8932 begin left_x(r):=x_coord(r); 8933 if right_x(pp)>x_coord(r) then right_x(pp):=x_coord(r); 8934 end; 8935if right_x(r)<x_coord(r) then 8936 begin right_x(r):=x_coord(r); 8937 if left_x(qq)<x_coord(r) then left_x(qq):=x_coord(r); 8938 end; 8939del2:=t_of_the_way(del2)(del3); 8940 {now |0,del2,del3| represent $y'$ on the remaining interval} 8941if del2>0 then del2:=0; 8942t:=crossing_point(0,-del2,-del3); 8943if t<fraction_one then @<Subdivide the cubic a second time 8944 with respect to $y'$@> 8945else begin if y_coord(r)>dest_y then 8946 begin y_coord(r):=dest_y; left_y(r):=-y_coord(r); right_y(r):=y_coord(r); 8947 end; 8948 if left_y(qq)>dest_y then left_y(qq):=dest_y 8949 else if left_y(qq)<y_coord(r) then left_y(qq):=y_coord(r); 8950 end; 8951end 8952 8953@ @<Subdivide the cubic a second time with respect to $y'$@>= 8954begin split_cubic(r,t,dest_x,dest_y); s:=link(r);@/ 8955if y_coord(s)<dest_y then y_coord(s):=dest_y; 8956if y_coord(s)<y_coord(r) then y_coord(s):=y_coord(r); 8957right_type(s):=right_type(pp); 8958left_y(s):=y_coord(s); {now |y_coord(r)=right_y(r)<=left_y(s)|} 8959if left_y(qq)<dest_y then left_y(qq):=-dest_y 8960else if left_y(qq)>y_coord(s) then left_y(qq):=-y_coord(s) 8961else negate(left_y(qq)); 8962negate(y_coord(s)); right_y(s):=y_coord(s); 8963if x_coord(s)<x_coord(r) then x_coord(s):=x_coord(r) 8964else if x_coord(s)>dest_x then x_coord(s):=dest_x; 8965if left_x(s)>x_coord(s) then 8966 begin left_x(s):=x_coord(s); 8967 if right_x(r)>x_coord(s) then right_x(r):=x_coord(s); 8968 end; 8969if right_x(s)<x_coord(s) then 8970 begin right_x(s):=x_coord(s); 8971 if left_x(qq)<x_coord(s) then left_x(qq):=x_coord(s); 8972 end; 8973end 8974 8975@ If the cubic is constant in $y$ and increasing in $x$, we have classified 8976it as traveling in the first octant. If the cubic is constant 8977in~$y$ and decreasing in~$x$, it is desirable to classify it as traveling 8978in the fifth octant (not the fourth), because autorounding will be consistent 8979with respect to doublepaths only if the octant number changes by four when 8980the path is reversed. Therefore we negate the $y$~coordinates 8981when they are constant but the curve is decreasing in~$x$; this gives 8982the desired result except in pathological paths. 8983 8984If the cubic is ``dead,'' i.e., constant in both |x| and |y|, we remove 8985it unless it is the only cubic in the entire path. We |goto continue| 8986if it wasn't the final cubic, so that the test |p=cur_spec| does not 8987falsely imply that all cubics have been processed. 8988 8989@<Do any special actions needed when |y| is constant...@>= 8990if constant_x then {|p=pp|, |q=qq|, and the cubic is dead} 8991 begin if q<>p then 8992 begin remove_cubic(p); {remove the dead cycle and recycle node |q|} 8993 if cur_spec<>q then goto continue 8994 else begin cur_spec:=p; return; 8995 end; {the final cubic was dead and is gone} 8996 end; 8997 end 8998else if not odd(right_type(pp)) then {the $x$ coordinates were negated} 8999 @<Complement the |y| coordinates...@> 9000 9001@ A similar correction to octant codes deserves to be made when |x| is 9002constant and |y| is decreasing. 9003 9004@<Correct the octant code in segments with decreasing |y|@>= 9005begin pp:=p; 9006repeat qq:=link(pp); 9007if right_type(pp)>negate_y then {the $y$ coordinates were negated} 9008 begin right_type(pp):=right_type(pp)+negate_x; 9009 negate(x_coord(pp)); negate(right_x(pp)); negate(left_x(qq)); 9010 end; 9011pp:=qq; 9012until pp=q; 9013end 9014 9015@ Finally, the process of subdividing to make $x'\G y'$ is like the other 9016two subdivisions, with a few new twists. We skew the coordinates at this time. 9017 9018@<Declare subroutines needed by |make_spec|@>= 9019procedure octant_subdivide; 9020var @!p,@!q,@!r,@!s:pointer; {for traversing the lists} 9021@!del1,@!del2,@!del3,@!del,@!dmax:scaled; {proportional to the control 9022 points of a quadratic derived from a cubic} 9023@!t:fraction; {where a quadratic crosses zero} 9024@!dest_x,@!dest_y:scaled; {final values of |x| and |y| in the current cubic} 9025begin p:=cur_spec; 9026repeat q:=link(p);@/ 9027x_coord(p):=x_coord(p)-y_coord(p); 9028right_x(p):=right_x(p)-right_y(p); 9029left_x(q):=left_x(q)-left_y(q);@/ 9030@<Subdivide the cubic between |p| and |q| so that the results travel 9031 toward the first octant@>; 9032p:=q; 9033until p=cur_spec; 9034end; 9035 9036@ @<Subdivide the cubic between |p| and |q| so that the results travel 9037 toward the first octant@>= 9038@<Set up the variables |(del1,del2,del3)| to represent $x'-y'$@>; 9039@<Scale up |del1|, |del2|, and |del3| for greater accuracy; 9040 also set |del| to the first nonzero element of |(del1,del2,del3)|@>; 9041if del<>0 then {they weren't all zero} 9042 begin if del<0 then @<Swap the |x| and |y| coordinates of the 9043 cubic between |p| and~|q|@>; 9044 t:=crossing_point(del1,del2,del3); 9045 if t<fraction_one then 9046 @<Subdivide the cubic with respect to $x'-y'$, possibly twice@>; 9047 end 9048 9049@ @<Set up the variables |(del1,del2,del3)| to represent $x'-y'$@>= 9050if q=cur_spec then 9051 begin unskew(x_coord(q),y_coord(q),right_type(q)); 9052 skew(cur_x,cur_y,right_type(p)); dest_x:=cur_x; dest_y:=cur_y; 9053 end 9054else begin abnegate(x_coord(q),y_coord(q),right_type(q),right_type(p)); 9055 dest_x:=cur_x-cur_y; dest_y:=cur_y; 9056 end; 9057del1:=right_x(p)-x_coord(p); del2:=left_x(q)-right_x(p); 9058del3:=dest_x-left_x(q) 9059 9060@ The swapping here doesn't simply interchange |x| and |y| values, 9061because the coordinates are skewed. It turns out that this is easier 9062than ordinary swapping, because it can be done in two assignment statements 9063rather than three. 9064 9065@ @<Swap the |x| and |y| coordinates...@>= 9066begin y_coord(p):=x_coord(p)+y_coord(p); negate(x_coord(p));@/ 9067right_y(p):=right_x(p)+right_y(p); negate(right_x(p));@/ 9068left_y(q):=left_x(q)+left_y(q); negate(left_x(q));@/ 9069negate(del1); negate(del2); negate(del3);@/ 9070dest_y:=dest_x+dest_y; negate(dest_x);@/ 9071right_type(p):=right_type(p)+switch_x_and_y; 9072end 9073 9074@ A somewhat tedious case analysis is carried out here to make sure that 9075nasty rounding errors don't destroy our assumptions of monotonicity. 9076 9077@<Subdivide the cubic with respect to $x'-y'$, possibly twice@>= 9078begin split_cubic(p,t,dest_x,dest_y); r:=link(p); 9079if right_type(r)>switch_x_and_y then right_type(r):=right_type(r)-switch_x_and_y 9080else right_type(r):=right_type(r)+switch_x_and_y; 9081if y_coord(r)<y_coord(p) then y_coord(r):=y_coord(p) 9082else if y_coord(r)>dest_y then y_coord(r):=dest_y; 9083if x_coord(p)+y_coord(r)>dest_x+dest_y then 9084 y_coord(r):=dest_x+dest_y-x_coord(p); 9085if left_y(r)>y_coord(r) then 9086 begin left_y(r):=y_coord(r); 9087 if right_y(p)>y_coord(r) then right_y(p):=y_coord(r); 9088 end; 9089if right_y(r)<y_coord(r) then 9090 begin right_y(r):=y_coord(r); 9091 if left_y(q)<y_coord(r) then left_y(q):=y_coord(r); 9092 end; 9093if x_coord(r)<x_coord(p) then x_coord(r):=x_coord(p) 9094else if x_coord(r)+y_coord(r)>dest_x+dest_y then 9095 x_coord(r):=dest_x+dest_y-y_coord(r); 9096left_x(r):=x_coord(r); 9097if right_x(p)>x_coord(r) then right_x(p):=x_coord(r); 9098 {we always have |x_coord(p)<=right_x(p)|} 9099y_coord(r):=y_coord(r)+x_coord(r); right_y(r):=right_y(r)+x_coord(r);@/ 9100negate(x_coord(r)); right_x(r):=x_coord(r);@/ 9101left_y(q):=left_y(q)+left_x(q); negate(left_x(q));@/ 9102dest_y:=dest_y+dest_x; negate(dest_x); 9103if right_y(r)<y_coord(r) then 9104 begin right_y(r):=y_coord(r); 9105 if left_y(q)<y_coord(r) then left_y(q):=y_coord(r); 9106 end; 9107del2:=t_of_the_way(del2)(del3); 9108 {now |0,del2,del3| represent $x'-y'$ on the remaining interval} 9109if del2>0 then del2:=0; 9110t:=crossing_point(0,-del2,-del3); 9111if t<fraction_one then 9112 @<Subdivide the cubic a second time with respect to $x'-y'$@> 9113else begin if x_coord(r)>dest_x then 9114 begin x_coord(r):=dest_x; left_x(r):=-x_coord(r); right_x(r):=x_coord(r); 9115 end; 9116 if left_x(q)>dest_x then left_x(q):=dest_x 9117 else if left_x(q)<x_coord(r) then left_x(q):=x_coord(r); 9118 end; 9119end 9120 9121@ @<Subdivide the cubic a second time with respect to $x'-y'$@>= 9122begin split_cubic(r,t,dest_x,dest_y); s:=link(r);@/ 9123if y_coord(s)<y_coord(r) then y_coord(s):=y_coord(r) 9124else if y_coord(s)>dest_y then y_coord(s):=dest_y; 9125if x_coord(r)+y_coord(s)>dest_x+dest_y then 9126 y_coord(s):=dest_x+dest_y-x_coord(r); 9127if left_y(s)>y_coord(s) then 9128 begin left_y(s):=y_coord(s); 9129 if right_y(r)>y_coord(s) then right_y(r):=y_coord(s); 9130 end; 9131if right_y(s)<y_coord(s) then 9132 begin right_y(s):=y_coord(s); 9133 if left_y(q)<y_coord(s) then left_y(q):=y_coord(s); 9134 end; 9135if x_coord(s)+y_coord(s)>dest_x+dest_y then x_coord(s):=dest_x+dest_y-y_coord(s) 9136else begin if x_coord(s)<dest_x then x_coord(s):=dest_x; 9137 if x_coord(s)<x_coord(r) then x_coord(s):=x_coord(r); 9138 end; 9139right_type(s):=right_type(p); 9140left_x(s):=x_coord(s); {now |x_coord(r)=right_x(r)<=left_x(s)|} 9141if left_x(q)<dest_x then 9142 begin left_y(q):=left_y(q)+dest_x; left_x(q):=-dest_x;@+end 9143else if left_x(q)>x_coord(s) then 9144 begin left_y(q):=left_y(q)+x_coord(s); left_x(q):=-x_coord(s);@+end 9145else begin left_y(q):=left_y(q)+left_x(q); negate(left_x(q));@+end; 9146y_coord(s):=y_coord(s)+x_coord(s); right_y(s):=right_y(s)+x_coord(s);@/ 9147negate(x_coord(s)); right_x(s):=x_coord(s);@/ 9148if right_y(s)<y_coord(s) then 9149 begin right_y(s):=y_coord(s); 9150 if left_y(q)<y_coord(s) then left_y(q):=y_coord(s); 9151 end; 9152end 9153 9154@ It's time now to consider ``autorounding,'' which tries to make horizontal, 9155vertical, and diagonal tangents occur at places that will produce appropriate 9156images after the curve is digitized. 9157 9158The first job is to fix things so that |x(t)| plus the horizontal pen offset 9159is an integer multiple of the 9160current ``granularity'' when the derivative $x'(t)$ crosses through zero. 9161The given cyclic path contains regions where $x'(t)\G0$ and regions 9162where $x'(t)\L0$. The |quadrant_subdivide| routine is called into action 9163before any of the path coordinates have been skewed, but some of them 9164may have been negated. In regions where $x'(t)\G0$ we have |right_type= 9165first_octant| or |right_type=eighth_octant|; in regions where $x'(t)\L0$, 9166we have |right_type=fifth_octant| or |right_type=fourth_octant|. 9167 9168Within any such region the transformed $x$ values increase monotonically 9169from, say, $x_0$ to~$x_1$. We want to modify things by applying a linear 9170transformation to all $x$ coordinates in the region, after which 9171the $x$ values will increase monotonically from round$(x_0)$ to round$(x_1)$. 9172 9173This rounding scheme sounds quite simple, and it usually is. But several 9174complications can arise that might make the task more difficult. In the 9175first place, autorounding is inappropriate at cusps where $x'$ jumps 9176discontinuously past zero without ever being zero. In the second place, 9177the current pen might be unsymmetric in such a way that $x$ coordinates 9178should round differently in different parts of the curve. 9179These considerations imply that round$(x_0)$ might be greater 9180than round$(x_1)$, even though $x_0\L x_1$; in such cases we do not want 9181to carry out the linear transformation. Furthermore, it's possible to have 9182round$(x_1)-\hbox{round} (x_0)$ positive but much greater than $x_1-x_0$; 9183then the transformation might distort the curve drastically, and again we 9184want to avoid it. Finally, the rounded points must be consistent between 9185adjacent regions, hence we can't transform one region without knowing 9186about its neighbors. 9187 9188To handle all these complications, we must first look at the whole 9189cycle and choose rounded $x$ values that are ``safe.'' The following 9190procedure does this: Given $m$~values $(b_0,b_1,\ldots,b_{m-1})$ before 9191rounding and $m$~corresponding values $(a_0,a_1,\ldots,a_{m-1})$ that would 9192be desirable after rounding, the |make_safe| routine sets $a$'s to $b$'s 9193if necessary so that $0\L(a\k-a_k)/(b\k-b_k)\L2$ afterwards. It is 9194symmetric under cyclic permutation, reversal, and/or negation of the inputs. 9195(Instead of |a|, |b|, and~|m|, the program uses the names |after|, 9196|before|, and |cur_rounding_ptr|.) 9197 9198@<Declare subroutines needed by |make_spec|@>= 9199procedure make_safe; 9200var @!k:0..max_wiggle; {runs through the list of inputs} 9201@!all_safe:boolean; {does everything look OK so far?} 9202@!next_a:scaled; {|after[k]| before it might have changed} 9203@!delta_a,@!delta_b:scaled; {|after[k+1]-after[k]| and |before[k+1]-before[k]|} 9204begin before[cur_rounding_ptr]:=before[0]; {wrap around} 9205node_to_round[cur_rounding_ptr]:=node_to_round[0]; 9206repeat after[cur_rounding_ptr]:=after[0]; all_safe:=true; next_a:=after[0]; 9207for k:=0 to cur_rounding_ptr-1 do 9208 begin delta_b:=before[k+1]-before[k]; 9209 if delta_b>=0 then delta_a:=after[k+1]-next_a 9210 else delta_a:=next_a-after[k+1]; 9211 next_a:=after[k+1]; 9212 if (delta_a<0)or(delta_a>abs(delta_b+delta_b)) then 9213 begin all_safe:=false; after[k]:=before[k]; 9214 if k=cur_rounding_ptr-1 then after[0]:=before[0] 9215 else after[k+1]:=before[k+1]; 9216 end; 9217 end; 9218until all_safe; 9219end; 9220 9221@ The global arrays used by |make_safe| are accompanied by an array of 9222pointers into the current knot list. 9223 9224@<Glob...@>= 9225@!before,@!after:array[0..max_wiggle] of scaled; {data for |make_safe|} 9226@!node_to_round:array[0..max_wiggle] of pointer; {reference back to the path} 9227@!cur_rounding_ptr:0..max_wiggle; {how many are being used} 9228@!max_rounding_ptr:0..max_wiggle; {how many have been used} 9229 9230@ @<Set init...@>= 9231max_rounding_ptr:=0; 9232 9233@ New entries go into the tables via the |before_and_after| routine: 9234 9235@<Declare subroutines needed by |make_spec|@>= 9236procedure before_and_after(@!b,@!a:scaled;@!p:pointer); 9237begin if cur_rounding_ptr=max_rounding_ptr then 9238 if max_rounding_ptr<max_wiggle then incr(max_rounding_ptr) 9239 else overflow("rounding table size",max_wiggle); 9240@:METAFONT capacity exceeded rounding table size}{\quad rounding table size@> 9241after[cur_rounding_ptr]:=a; before[cur_rounding_ptr]:=b; 9242node_to_round[cur_rounding_ptr]:=p; incr(cur_rounding_ptr); 9243end; 9244 9245@ A global variable called |cur_gran| is used instead of |internal[ 9246granularity]|, because we want to work with a number that's guaranteed to 9247be positive. 9248 9249@<Glob...@>= 9250@!cur_gran:scaled; {the current granularity (which normally is |unity|)} 9251 9252@ The |good_val| function computes a number |a| that's as close as 9253possible to~|b|, with the property that |a+o| is a multiple of 9254|cur_gran|. 9255 9256If we assume that |cur_gran| is even (since it will in fact be a multiple 9257of |unity| in all reasonable applications), we have the identity 9258|good_val(-b-1,-o)=-good_val(b,o)|. 9259 9260@<Declare subroutines needed by |make_spec|@>= 9261function good_val(@!b,@!o:scaled):scaled; 9262var @!a:scaled; {accumulator} 9263begin a:=b+o; 9264if a>=0 then a:=a-(a mod cur_gran)-o 9265else a:=a+((-(a+1)) mod cur_gran)-cur_gran+1-o; 9266if b-a<a+cur_gran-b then good_val:=a 9267else good_val:=a+cur_gran; 9268end; 9269 9270@ When we're rounding a doublepath, we might need to compromise between 9271two opposing tendencies, if the pen thickness is not a multiple of the 9272granularity. The following ``compromise'' adjustment, suggested by 9273John Hobby, finds the best way out of the dilemma. (Only the value 9274@^Hobby, John Douglas@> 9275modulo |cur_gran| is relevant in our applications, so the result turns 9276out to be essentially symmetric in |u| and~|v|.) 9277 9278@<Declare subroutines needed by |make_spec|@>= 9279function compromise(@!u,@!v:scaled):scaled; 9280begin compromise:=half(good_val(u+u,-u-v)); 9281end; 9282 9283@ Here, then, is the procedure that rounds $x$ coordinates as described; 9284it does the same for $y$ coordinates too, independently. 9285 9286@<Declare subroutines needed by |make_spec|@>= 9287procedure xy_round; 9288var @!p,@!q:pointer; {list manipulation registers} 9289@!b,@!a:scaled; {before and after values} 9290@!pen_edge:scaled; {offset that governs rounding} 9291@!alpha:fraction; {coefficient of linear transformation} 9292begin cur_gran:=abs(internal[granularity]); 9293if cur_gran=0 then cur_gran:=unity; 9294p:=cur_spec; cur_rounding_ptr:=0; 9295repeat q:=link(p); 9296@<If node |q| is a transition point for |x| coordinates, 9297 compute and save its before-and-after coordinates@>; 9298p:=q; 9299until p=cur_spec; 9300if cur_rounding_ptr>0 then @<Transform the |x| coordinates@>; 9301p:=cur_spec; cur_rounding_ptr:=0; 9302repeat q:=link(p); 9303@<If node |q| is a transition point for |y| coordinates, 9304 compute and save its before-and-after coordinates@>; 9305p:=q; 9306until p=cur_spec; 9307if cur_rounding_ptr>0 then @<Transform the |y| coordinates@>; 9308end; 9309 9310@ When |x| has been negated, the |octant| codes are even. We allow 9311for an error of up to .01 pixel (i.e., 655 |scaled| units) in the 9312derivative calculations at transition nodes. 9313 9314@<If node |q| is a transition point for |x| coordinates...@>= 9315if odd(right_type(p))<>odd(right_type(q)) then 9316 begin if odd(right_type(q)) then b:=x_coord(q)@+else b:=-x_coord(q); 9317 if (abs(x_coord(q)-right_x(q))<655)or@| 9318 (abs(x_coord(q)+left_x(q))<655) then 9319 @<Compute before-and-after |x| values based on the current pen@> 9320 else a:=b; 9321 if abs(a)>max_allowed then 9322 if a>0 then a:=max_allowed@+else a:=-max_allowed; 9323 before_and_after(b,a,q); 9324 end 9325 9326@ When we study the data representation for pens, we'll learn that the 9327|x|~coordinate of the current pen's west edge is 9328$$\hbox{|y_coord(link(cur_pen+seventh_octant))|},$$ 9329and that there are similar ways to address other important offsets. 9330 9331@d north_edge(#)==y_coord(link(#+fourth_octant)) 9332@d south_edge(#)==y_coord(link(#+first_octant)) 9333@d east_edge(#)==y_coord(link(#+second_octant)) 9334@d west_edge(#)==y_coord(link(#+seventh_octant)) 9335 9336@<Compute before-and-after |x| values based on the current pen@>= 9337begin if cur_pen=null_pen then pen_edge:=0 9338else if cur_path_type=double_path_code then 9339 pen_edge:=compromise(east_edge(cur_pen),west_edge(cur_pen)) 9340else if odd(right_type(q)) then pen_edge:=west_edge(cur_pen) 9341else pen_edge:=east_edge(cur_pen); 9342a:=good_val(b,pen_edge); 9343end 9344 9345@ The monotone transformation computed here with fixed-point arithmetic is 9346guaranteed to take consecutive |before| values $(b,b')$ into consecutive 9347|after| values $(a,a')$, even in the presence of rounding errors, 9348as long as $\vert b-b'\vert<2^{28}$. 9349 9350@<Transform the |x| coordinates@>= 9351begin make_safe; 9352repeat decr(cur_rounding_ptr); 9353if (after[cur_rounding_ptr]<>before[cur_rounding_ptr])or@| 9354 (after[cur_rounding_ptr+1]<>before[cur_rounding_ptr+1]) then 9355 begin p:=node_to_round[cur_rounding_ptr]; 9356 if odd(right_type(p)) then 9357 begin b:=before[cur_rounding_ptr]; a:=after[cur_rounding_ptr]; 9358 end 9359 else begin b:=-before[cur_rounding_ptr]; a:=-after[cur_rounding_ptr]; 9360 end; 9361 if before[cur_rounding_ptr]=before[cur_rounding_ptr+1] then 9362 alpha:=fraction_one 9363 else alpha:=make_fraction(after[cur_rounding_ptr+1]-after[cur_rounding_ptr],@| 9364 before[cur_rounding_ptr+1]-before[cur_rounding_ptr]); 9365 repeat x_coord(p):=take_fraction(alpha,x_coord(p)-b)+a; 9366 right_x(p):=take_fraction(alpha,right_x(p)-b)+a; 9367 p:=link(p); left_x(p):=take_fraction(alpha,left_x(p)-b)+a; 9368 until p=node_to_round[cur_rounding_ptr+1]; 9369 end; 9370until cur_rounding_ptr=0; 9371end 9372 9373@ When |y| has been negated, the |octant| codes are |>negate_y|. Otherwise 9374these routines are essentially identical to the routines for |x| coordinates 9375that we have just seen. 9376 9377@<If node |q| is a transition point for |y| coordinates...@>= 9378if (right_type(p)>negate_y)<>(right_type(q)>negate_y) then 9379 begin if right_type(q)<=negate_y then b:=y_coord(q)@+else b:=-y_coord(q); 9380 if (abs(y_coord(q)-right_y(q))<655)or@| 9381 (abs(y_coord(q)+left_y(q))<655) then 9382 @<Compute before-and-after |y| values based on the current pen@> 9383 else a:=b; 9384 if abs(a)>max_allowed then 9385 if a>0 then a:=max_allowed@+else a:=-max_allowed; 9386 before_and_after(b,a,q); 9387 end 9388 9389@ @<Compute before-and-after |y| values based on the current pen@>= 9390begin if cur_pen=null_pen then pen_edge:=0 9391else if cur_path_type=double_path_code then 9392 pen_edge:=compromise(north_edge(cur_pen),south_edge(cur_pen)) 9393else if right_type(q)<=negate_y then pen_edge:=south_edge(cur_pen) 9394else pen_edge:=north_edge(cur_pen); 9395a:=good_val(b,pen_edge); 9396end 9397 9398@ @<Transform the |y| coordinates@>= 9399begin make_safe; 9400repeat decr(cur_rounding_ptr); 9401if (after[cur_rounding_ptr]<>before[cur_rounding_ptr])or@| 9402 (after[cur_rounding_ptr+1]<>before[cur_rounding_ptr+1]) then 9403 begin p:=node_to_round[cur_rounding_ptr]; 9404 if right_type(p)<=negate_y then 9405 begin b:=before[cur_rounding_ptr]; a:=after[cur_rounding_ptr]; 9406 end 9407 else begin b:=-before[cur_rounding_ptr]; a:=-after[cur_rounding_ptr]; 9408 end; 9409 if before[cur_rounding_ptr]=before[cur_rounding_ptr+1] then 9410 alpha:=fraction_one 9411 else alpha:=make_fraction(after[cur_rounding_ptr+1]-after[cur_rounding_ptr],@| 9412 before[cur_rounding_ptr+1]-before[cur_rounding_ptr]); 9413 repeat y_coord(p):=take_fraction(alpha,y_coord(p)-b)+a; 9414 right_y(p):=take_fraction(alpha,right_y(p)-b)+a; 9415 p:=link(p); left_y(p):=take_fraction(alpha,left_y(p)-b)+a; 9416 until p=node_to_round[cur_rounding_ptr+1]; 9417 end; 9418until cur_rounding_ptr=0; 9419end 9420 9421@ Rounding at diagonal tangents takes place after the subdivision into 9422octants is complete, hence after the coordinates have been skewed. 9423The details are somewhat tricky, because we want to round to points 9424whose skewed coordinates are halfway between integer multiples of 9425the granularity. Furthermore, both coordinates change when they are 9426rounded; this means we need a generalization of the |make_safe| routine, 9427ensuring safety in both |x| and |y|. 9428 9429In spite of these extra complications, we can take comfort in the fact 9430that the basic structure of the routine is the same as before. 9431 9432@<Declare subroutines needed by |make_spec|@>= 9433procedure diag_round; 9434var @!p,@!q,@!pp:pointer; {list manipulation registers} 9435@!b,@!a,@!bb,@!aa,@!d,@!c,@!dd,@!cc:scaled; {before and after values} 9436@!pen_edge:scaled; {offset that governs rounding} 9437@!alpha,@!beta:fraction; {coefficients of linear transformation} 9438@!next_a:scaled; {|after[k]| before it might have changed} 9439@!all_safe:boolean; {does everything look OK so far?} 9440@!k:0..max_wiggle; {runs through before-and-after values} 9441@!first_x,@!first_y:scaled; {coordinates before rounding} 9442begin p:=cur_spec; cur_rounding_ptr:=0; 9443repeat q:=link(p); 9444@<If node |q| is a transition point between octants, 9445 compute and save its before-and-after coordinates@>; 9446p:=q; 9447until p=cur_spec; 9448if cur_rounding_ptr>0 then @<Transform the skewed coordinates@>; 9449end; 9450 9451@ We negate the skewed |x| coordinates in the before-and-after table when 9452the octant code is greater than |switch_x_and_y|. 9453 9454@<If node |q| is a transition point between octants...@>= 9455if right_type(p)<>right_type(q) then 9456 begin if right_type(q)>switch_x_and_y then b:=-x_coord(q) 9457 else b:=x_coord(q); 9458 if abs(right_type(q)-right_type(p))=switch_x_and_y then 9459 if (abs(x_coord(q)-right_x(q))<655)or(abs(x_coord(q)+left_x(q))<655) then 9460 @<Compute a good coordinate at a diagonal transition@> 9461 else a:=b 9462 else a:=b; 9463 before_and_after(b,a,q); 9464 end 9465 9466@ In octants whose code number is even, $x$~has been 9467negated; we want to round ambiguous cases downward instead of upward, 9468so that the rounding will be consistent with octants whose code 9469number is odd. This downward bias can be achieved by 9470subtracting~1 from the first argument of |good_val|. 9471 9472@d diag_offset(#)==x_coord(knil(link(cur_pen+#))) 9473 9474@<Compute a good coordinate at a diagonal transition@>= 9475begin if cur_pen=null_pen then pen_edge:=0 9476else if cur_path_type=double_path_code then @<Compute a compromise |pen_edge|@> 9477else if right_type(q)<=switch_x_and_y then pen_edge:=diag_offset(right_type(q)) 9478else pen_edge:=-diag_offset(right_type(q)); 9479if odd(right_type(q)) then a:=good_val(b,pen_edge+half(cur_gran)) 9480else a:=good_val(b-1,pen_edge+half(cur_gran)); 9481end 9482 9483@ (It seems a shame to compute these compromise offsets repeatedly. The 9484author would have stored them directly in the pen data structure, if the 9485granularity had been constant.) 9486 9487@<Compute a compromise...@>= 9488case right_type(q) of 9489first_octant,second_octant:pen_edge:=compromise(diag_offset(first_octant),@| 9490 -diag_offset(fifth_octant)); 9491fifth_octant,sixth_octant:pen_edge:=-compromise(diag_offset(first_octant),@| 9492 -diag_offset(fifth_octant)); 9493third_octant,fourth_octant:pen_edge:=compromise(diag_offset(fourth_octant),@| 9494 -diag_offset(eighth_octant)); 9495seventh_octant,eighth_octant:pen_edge:=-compromise(diag_offset(fourth_octant),@| 9496 -diag_offset(eighth_octant)); 9497end {there are no other cases} 9498 9499@ @<Transform the skewed coordinates@>= 9500begin p:=node_to_round[0]; first_x:=x_coord(p); first_y:=y_coord(p); 9501@<Make sure that all the diagonal roundings are safe@>; 9502for k:=0 to cur_rounding_ptr-1 do 9503 begin a:=after[k]; b:=before[k]; 9504 aa:=after[k+1]; bb:=before[k+1]; 9505 if (a<>b)or(aa<>bb) then 9506 begin p:=node_to_round[k]; pp:=node_to_round[k+1]; 9507 @<Determine the before-and-after values of both coordinates@>; 9508 if b=bb then alpha:=fraction_one 9509 else alpha:=make_fraction(aa-a,bb-b); 9510 if d=dd then beta:=fraction_one 9511 else beta:=make_fraction(cc-c,dd-d); 9512 repeat x_coord(p):=take_fraction(alpha,x_coord(p)-b)+a; 9513 y_coord(p):=take_fraction(beta,y_coord(p)-d)+c; 9514 right_x(p):=take_fraction(alpha,right_x(p)-b)+a; 9515 right_y(p):=take_fraction(beta,right_y(p)-d)+c; 9516 p:=link(p); left_x(p):=take_fraction(alpha,left_x(p)-b)+a; 9517 left_y(p):=take_fraction(beta,left_y(p)-d)+c; 9518 until p=pp; 9519 end; 9520 end; 9521end 9522 9523@ In node |p|, the coordinates |(b,d)| will be rounded to |(a,c)|; 9524in node |pp|, the coordinates |(bb,dd)| will be rounded to |(aa,cc)|. 9525(We transform the values from node |pp| so that they agree with the 9526conventions of node |p|.) 9527 9528If |aa<>bb|, we know that |abs(right_type(p)-right_type(pp))=switch_x_and_y|. 9529 9530@<Determine the before-and-after values of both coordinates@>= 9531if aa=bb then 9532 begin if pp=node_to_round[0] then 9533 unskew(first_x,first_y,right_type(pp)) 9534 else unskew(x_coord(pp),y_coord(pp),right_type(pp)); 9535 skew(cur_x,cur_y,right_type(p)); 9536 bb:=cur_x; aa:=bb; dd:=cur_y; cc:=dd; 9537 if right_type(p)>switch_x_and_y then 9538 begin b:=-b; a:=-a; 9539 end; 9540 end 9541else begin if right_type(p)>switch_x_and_y then 9542 begin bb:=-bb; aa:=-aa; b:=-b; a:=-a; 9543 end; 9544 if pp=node_to_round[0] then dd:=first_y-bb@+else dd:=y_coord(pp)-bb; 9545 if odd(aa-bb) then 9546 if right_type(p)>switch_x_and_y then cc:=dd-half(aa-bb+1) 9547 else cc:=dd-half(aa-bb-1) 9548 else cc:=dd-half(aa-bb); 9549 end; 9550d:=y_coord(p); 9551if odd(a-b) then 9552 if right_type(p)>switch_x_and_y then c:=d-half(a-b-1) 9553 else c:=d-half(a-b+1) 9554else c:=d-half(a-b) 9555 9556@ @<Make sure that all the diagonal roundings are safe@>= 9557before[cur_rounding_ptr]:=before[0]; {cf.~|make_safe|} 9558node_to_round[cur_rounding_ptr]:=node_to_round[0]; 9559repeat after[cur_rounding_ptr]:=after[0]; all_safe:=true; next_a:=after[0]; 9560for k:=0 to cur_rounding_ptr-1 do 9561 begin a:=next_a; b:=before[k]; next_a:=after[k+1]; 9562 aa:=next_a; bb:=before[k+1]; 9563 if (a<>b)or(aa<>bb) then 9564 begin p:=node_to_round[k]; pp:=node_to_round[k+1]; 9565 @<Determine the before-and-after values of both coordinates@>; 9566 if (aa<a)or(cc<c)or(aa-a>2*(bb-b))or(cc-c>2*(dd-d)) then 9567 begin all_safe:=false; after[k]:=before[k]; 9568 if k=cur_rounding_ptr-1 then after[0]:=before[0] 9569 else after[k+1]:=before[k+1]; 9570 end; 9571 end; 9572 end; 9573until all_safe 9574 9575@ Here we get rid of ``dead'' cubics, i.e., polynomials that don't move at 9576all when |t|~changes, since the subdivision process might have introduced 9577such things. If the cycle reduces to a single point, however, we are left 9578with a single dead cubic that will not be removed until later. 9579 9580@<Remove dead cubics@>= 9581p:=cur_spec; 9582repeat continue: q:=link(p); 9583if p<>q then 9584 begin if x_coord(p)=right_x(p) then 9585 if y_coord(p)=right_y(p) then 9586 if x_coord(p)=left_x(q) then 9587 if y_coord(p)=left_y(q) then 9588 begin unskew(x_coord(q),y_coord(q),right_type(q)); 9589 skew(cur_x,cur_y,right_type(p)); 9590 if x_coord(p)=cur_x then if y_coord(p)=cur_y then 9591 begin remove_cubic(p); {remove the cubic following |p|} 9592 if q<>cur_spec then goto continue; 9593 cur_spec:=p; q:=p; 9594 end; 9595 end; 9596 end; 9597p:=q; 9598until p=cur_spec; 9599 9600@ Finally we come to the last steps of |make_spec|, when boundary nodes 9601are inserted between cubics that move in different octants. The main 9602complication remaining arises from consecutive cubics whose octants 9603are not adjacent; we should insert more than one octant boundary 9604at such sharp turns, so that the envelope-forming routine will work. 9605 9606For this purpose, conversion tables between numeric and Gray codes for 9607octants are desirable. 9608 9609@<Glob...@>= 9610@!octant_number:array[first_octant..sixth_octant] of 1..8; 9611@!octant_code:array[1..8] of first_octant..sixth_octant; 9612 9613@ @<Set init...@>= 9614octant_code[1]:=first_octant; 9615octant_code[2]:=second_octant; 9616octant_code[3]:=third_octant; 9617octant_code[4]:=fourth_octant; 9618octant_code[5]:=fifth_octant; 9619octant_code[6]:=sixth_octant; 9620octant_code[7]:=seventh_octant; 9621octant_code[8]:=eighth_octant; 9622for k:=1 to 8 do octant_number[octant_code[k]]:=k; 9623 9624@ The main loop for boundary insertion deals with three consecutive 9625nodes |p,q,r|. 9626 9627@<Insert octant boundaries and compute the turning number@>= 9628turning_number:=0; 9629p:=cur_spec; q:=link(p); 9630repeat r:=link(q); 9631if (right_type(p)<>right_type(q))or(q=r) then 9632 @<Insert one or more octant boundary nodes just before~|q|@>; 9633p:=q; q:=r; 9634until p=cur_spec; 9635 9636@ The |new_boundary| subroutine comes in handy at this point. It inserts 9637a new boundary node just after a given node |p|, using a given octant code 9638to transform the new node's coordinates. The ``transition'' fields are 9639not computed here. 9640 9641@<Declare subroutines needed by |make_spec|@>= 9642procedure new_boundary(@!p:pointer;@!octant:small_number); 9643var @!q,@!r:pointer; {for list manipulation} 9644begin q:=link(p); {we assume that |right_type(q)<>endpoint|} 9645r:=get_node(knot_node_size); link(r):=q; link(p):=r; 9646left_type(r):=left_type(q); {but possibly |left_type(q)=endpoint|} 9647left_x(r):=left_x(q); left_y(r):=left_y(q); 9648right_type(r):=endpoint; left_type(q):=endpoint; 9649right_octant(r):=octant; left_octant(q):=right_type(q); 9650unskew(x_coord(q),y_coord(q),right_type(q)); 9651skew(cur_x,cur_y,octant); x_coord(r):=cur_x; y_coord(r):=cur_y; 9652end; 9653 9654@ The case |q=r| occurs if and only if |p=q=r=cur_spec|, when we want to turn 9655$360^\circ$ in eight steps and then remove a solitary dead cubic. 9656The program below happens to work in that case, but the reader isn't 9657expected to understand why. 9658 9659@<Insert one or more octant boundary nodes just before~|q|@>= 9660begin new_boundary(p,right_type(p)); s:=link(p); 9661o1:=octant_number[right_type(p)]; o2:=octant_number[right_type(q)]; 9662case o2-o1 of 96631,-7,7,-1: goto done; 96642,-6: clockwise:=false; 96653,-5,4,-4,5,-3: @<Decide whether or not to go clockwise@>; 96666,-2: clockwise:=true; 96670:clockwise:=rev_turns; 9668end; {there are no other cases} 9669@<Insert additional boundary nodes, then |goto done|@>; 9670done: if q=r then 9671 begin q:=link(q); r:=q; p:=s; link(s):=q; left_octant(q):=right_octant(q); 9672 left_type(q):=endpoint; free_node(cur_spec,knot_node_size); cur_spec:=q; 9673 end; 9674@<Fix up the transition fields and adjust the turning number@>; 9675end 9676 9677@ @<Other local variables for |make_spec|@>= 9678@!o1,@!o2:small_number; {octant numbers} 9679@!clockwise:boolean; {should we turn clockwise?} 9680@!dx1,@!dy1,@!dx2,@!dy2:integer; {directions of travel at a cusp} 9681@!dmax,@!del:integer; {temporary registers} 9682 9683@ A tricky question arises when a path jumps four octants. We want the 9684direction of turning to be counterclockwise if the curve has changed 9685direction by $180^\circ$, or by something so close to $180^\circ$ that 9686the difference is probably due to rounding errors; otherwise we want to 9687turn through an angle of less than $180^\circ$. This decision needs to 9688be made even when a curve seems to have jumped only three octants, since 9689a curve may approach direction $(-1,0)$ from the fourth octant, then 9690it might leave from direction $(+1,0)$ into the first. 9691 9692The following code solves the problem by analyzing the incoming 9693direction |(dx1,dy1)| and the outgoing direction |(dx2,dy2)|. 9694 9695@<Decide whether or not to go clockwise@>= 9696begin @<Compute the incoming and outgoing directions@>; 9697unskew(dx1,dy1,right_type(p)); del:=pyth_add(cur_x,cur_y);@/ 9698dx1:=make_fraction(cur_x,del); dy1:=make_fraction(cur_y,del); 9699 {$\cos\theta_1$ and $\sin\theta_1$} 9700unskew(dx2,dy2,right_type(q)); del:=pyth_add(cur_x,cur_y);@/ 9701dx2:=make_fraction(cur_x,del); dy2:=make_fraction(cur_y,del); 9702 {$\cos\theta_2$ and $\sin\theta_2$} 9703del:=take_fraction(dx1,dy2)-take_fraction(dx2,dy1); {$\sin(\theta_2-\theta_1)$} 9704if del>4684844 then clockwise:=false 9705else if del<-4684844 then clockwise:=true 9706 {$2^{28}\cdot\sin 1^\circ\approx4684844.68$} 9707else clockwise:=rev_turns; 9708end 9709 9710@ Actually the turnarounds just computed will be clockwise, 9711not counterclockwise, if 9712the global variable |rev_turns| is |true|; it is usually |false|. 9713 9714@<Glob...@>= 9715@!rev_turns:boolean; {should we make U-turns in the English manner?} 9716 9717@ @<Set init...@>= 9718rev_turns:=false; 9719 9720@ @<Compute the incoming and outgoing directions@>= 9721dx1:=x_coord(s)-left_x(s); dy1:=y_coord(s)-left_y(s); 9722if dx1=0 then if dy1=0 then 9723 begin dx1:=x_coord(s)-right_x(p); dy1:=y_coord(s)-right_y(p); 9724 if dx1=0 then if dy1=0 then 9725 begin dx1:=x_coord(s)-x_coord(p); dy1:=y_coord(s)-y_coord(p); 9726 end; {and they {\sl can't} both be zero} 9727 end; 9728dmax:=abs(dx1);@+if abs(dy1)>dmax then dmax:=abs(dy1); 9729while dmax<fraction_one do 9730 begin double(dmax); double(dx1); double(dy1); 9731 end; 9732dx2:=right_x(q)-x_coord(q); dy2:=right_y(q)-y_coord(q); 9733if dx2=0 then if dy2=0 then 9734 begin dx2:=left_x(r)-x_coord(q); dy2:=left_y(r)-y_coord(q); 9735 if dx2=0 then if dy2=0 then 9736 begin if right_type(r)=endpoint then 9737 begin cur_x:=x_coord(r); cur_y:=y_coord(r); 9738 end 9739 else begin unskew(x_coord(r),y_coord(r),right_type(r)); 9740 skew(cur_x,cur_y,right_type(q)); 9741 end; 9742 dx2:=cur_x-x_coord(q); dy2:=cur_y-y_coord(q); 9743 end; {and they {\sl can't} both be zero} 9744 end; 9745dmax:=abs(dx2);@+if abs(dy2)>dmax then dmax:=abs(dy2); 9746while dmax<fraction_one do 9747 begin double(dmax); double(dx2); double(dy2); 9748 end 9749 9750@ @<Insert additional boundary nodes...@>= 9751loop@+ begin if clockwise then 9752 if o1=1 then o1:=8@+else decr(o1) 9753 else if o1=8 then o1:=1@+else incr(o1); 9754 if o1=o2 then goto done; 9755 new_boundary(s,octant_code[o1]); 9756 s:=link(s); left_octant(s):=right_octant(s); 9757 end 9758 9759@ Now it remains to insert the redundant 9760transition information into the |left_transition| 9761and |right_transition| fields between adjacent octants, in the octant 9762boundary nodes that have just been inserted between |link(p)| and~|q|. 9763The turning number is easily computed from these transitions. 9764 9765@<Fix up the transition fields and adjust the turning number@>= 9766p:=link(p); 9767repeat s:=link(p); 9768o1:=octant_number[right_octant(p)]; o2:=octant_number[left_octant(s)]; 9769if abs(o1-o2)=1 then 9770 begin if o2<o1 then o2:=o1; 9771 if odd(o2) then right_transition(p):=axis 9772 else right_transition(p):=diagonal; 9773 end 9774else begin if o1=8 then incr(turning_number)@+else decr(turning_number); 9775 right_transition(p):=axis; 9776 end; 9777left_transition(s):=right_transition(p); 9778p:=s; 9779until p=q 9780 9781@* \[22] Filling a contour. 9782Given the low-level machinery for making moves and for transforming a 9783cyclic path into a cycle spec, we're almost able to fill a digitized path. 9784All we need is a high-level routine that walks through the cycle spec and 9785controls the overall process. 9786 9787Our overall goal is to plot the integer points $\bigl(\round(x(t)), 9788\round(y(t))\bigr)$ and to connect them by rook moves, assuming that 9789$\round(x(t))$ and $\round(y(t))$ don't both jump simultaneously from 9790one integer to another as $t$~varies; these rook moves will be the edge 9791of the contour that will be filled. We have reduced this problem to the 9792case of curves that travel in first octant directions, i.e., curves 9793such that $0\L y'(t)\L x'(t)$, by transforming the original coordinates. 9794 9795\def\xtilde{{\tilde x}} \def\ytilde{{\tilde y}} 9796Another transformation makes the problem still simpler. We shall say that 9797we are working with {\sl biased coordinates\/} when $(x,y)$ has been 9798replaced by $(\xtilde,\ytilde)=(x-y,y+{1\over2})$. When a curve travels 9799in first octant directions, the corresponding curve with biased 9800coordinates travels in first {\sl quadrant\/} directions; the latter 9801condition is symmetric in $x$ and~$y$, so it has advantages for the 9802design of algorithms. The |make_spec| routine gives us skewed coordinates 9803$(x-y,y)$, hence we obtain biased coordinates by simply adding $1\over2$ 9804to the second component. 9805 9806The most important fact about biased coordinates is that we can determine the 9807rounded unbiased path $\bigl(\round(x(t)),\round(y(t))\bigr)$ from the 9808truncated biased path $\bigl(\lfloor\xtilde(t)\rfloor,\lfloor\ytilde(t)\rfloor 9809\bigr)$ and information about the initial and final endpoints. If the 9810unrounded and unbiased 9811path begins at $(x_0,y_0)$ and ends at $(x_1,y_1)$, it's possible to 9812prove (by induction on the length of the truncated biased path) that the 9813rounded unbiased path is obtained by the following construction: 9814 9815\yskip\textindent{1)} Start at $\bigl(\round(x_0),\round(y_0)\bigr)$. 9816 9817\yskip\textindent{2)} If $(x_0+{1\over2})\bmod1\G(y_0+{1\over2})\bmod1$, 9818move one step right. 9819 9820\yskip\textindent{3)} Whenever the path 9821$\bigl(\lfloor\xtilde(t)\rfloor,\lfloor\ytilde(t)\rfloor\bigr)$ 9822takes an upward step (i.e., when 9823$\lfloor\xtilde(t+\epsilon)\rfloor=\lfloor\xtilde(t)\rfloor$ and 9824$\lfloor\ytilde(t+\epsilon)\rfloor=\lfloor\ytilde(t)\rfloor+1$), 9825move one step up and then one step right. 9826 9827\yskip\textindent{4)} Whenever the path 9828$\bigl(\lfloor\xtilde(t)\rfloor,\lfloor\ytilde(t)\rfloor\bigr)$ 9829takes a rightward step (i.e., when 9830$\lfloor\xtilde(t+\epsilon)\rfloor=\lfloor\xtilde(t)\rfloor+1$ and 9831$\lfloor\ytilde(t+\epsilon)\rfloor=\lfloor\ytilde(t)\rfloor$), 9832move one step right. 9833 9834\yskip\textindent{5)} Finally, if 9835$(x_1+{1\over2})\bmod1\G(y_1+{1\over2})\bmod1$, move one step left (thereby 9836cancelling the previous move, which was one step right). You will now be 9837at the point $\bigl(\round(x_1),\round(y_1)\bigr)$. 9838 9839@ In order to validate the assumption that $\round(x(t))$ and $\round(y(t))$ 9840don't both jump simultaneously, we shall consider that a coordinate pair 9841$(x,y)$ actually represents $(x+\epsilon,y+\epsilon\delta)$, where 9842$\epsilon$ and $\delta$ are extremely small positive numbers---so small 9843that their precise values never matter. This convention makes rounding 9844unambiguous, since there is always a unique integer point nearest to any 9845given scaled numbers~$(x,y)$. 9846 9847When coordinates are transformed so that \MF\ needs to work only in ``first 9848octant'' directions, the transformations involve negating~$x$, negating~$y$, 9849and/or interchanging $x$ with~$y$. Corresponding adjustments to the 9850rounding conventions must be made so that consistent values will be 9851obtained. For example, suppose that we're working with coordinates that 9852have been transformed so that a third-octant curve travels in first-octant 9853directions. The skewed coordinates $(x,y)$ in our data structure represent 9854unskewed coordinates $(-y,x+y)$, which are actually $(-y+\epsilon, 9855x+y+\epsilon\delta)$. We should therefore round as if our skewed coordinates 9856were $(x+\epsilon+\epsilon\delta,y-\epsilon)$ instead of $(x,y)$. The following 9857table shows how the skewed coordinates should be perturbed when rounding 9858decisions are made: 9859$$\vcenter{\halign{#\hfil&&\quad$#$\hfil&\hskip4em#\hfil\cr 9860|first_octant|&(x+\epsilon-\epsilon\delta,y+\epsilon\delta)& 9861 |fifth_octant|&(x-\epsilon+\epsilon\delta,y-\epsilon\delta)\cr 9862|second_octant|&(x-\epsilon+\epsilon\delta,y+\epsilon)& 9863 |sixth_octant|&(x+\epsilon-\epsilon\delta,y-\epsilon)\cr 9864|third_octant|&(x+\epsilon+\epsilon\delta,y-\epsilon)& 9865 |seventh_octant|&(x-\epsilon-\epsilon\delta,y+\epsilon)\cr 9866|fourth_octant|&(x-\epsilon-\epsilon\delta,y+\epsilon\delta)& 9867 |eighth_octant|&(x+\epsilon+\epsilon\delta,y-\epsilon\delta)\cr}}$$ 9868 9869Four small arrays are set up so that the rounding operations will be 9870fairly easy in any given octant. 9871 9872@<Glob...@>= 9873@!y_corr,@!xy_corr,@!z_corr:array[first_octant..sixth_octant] of 0..1; 9874@!x_corr:array[first_octant..sixth_octant] of -1..1; 9875 9876@ Here |xy_corr| is 1 if and only if the $x$ component of a skewed coordinate 9877is to be decreased by an infinitesimal amount; |y_corr| is similar, but for 9878the $y$ components. The other tables are set up so that the condition 9879$$(x+y+|half_unit|)\bmod|unity|\G(y+|half_unit|)\bmod|unity|$$ 9880is properly perturbed to the condition 9881$$(x+y+|half_unit|-|x_corr|-|y_corr|)\bmod|unity|\G 9882 (y+|half_unit|-|y_corr|)\bmod|unity|+|z_corr|.$$ 9883 9884@<Set init...@>= 9885x_corr[first_octant]:=0; y_corr[first_octant]:=0; 9886xy_corr[first_octant]:=0;@/ 9887x_corr[second_octant]:=0; y_corr[second_octant]:=0; 9888xy_corr[second_octant]:=1;@/ 9889x_corr[third_octant]:=-1; y_corr[third_octant]:=1; 9890xy_corr[third_octant]:=0;@/ 9891x_corr[fourth_octant]:=1; y_corr[fourth_octant]:=0; 9892xy_corr[fourth_octant]:=1;@/ 9893x_corr[fifth_octant]:=0; y_corr[fifth_octant]:=1; 9894xy_corr[fifth_octant]:=1;@/ 9895x_corr[sixth_octant]:=0; y_corr[sixth_octant]:=1; 9896xy_corr[sixth_octant]:=0;@/ 9897x_corr[seventh_octant]:=1; y_corr[seventh_octant]:=0; 9898xy_corr[seventh_octant]:=1;@/ 9899x_corr[eighth_octant]:=-1; y_corr[eighth_octant]:=1; 9900xy_corr[eighth_octant]:=0;@/ 9901for k:=1 to 8 do z_corr[k]:=xy_corr[k]-x_corr[k]; 9902 9903@ Here's a procedure that handles the details of rounding at the 9904endpoints: Given skewed coordinates |(x,y)|, it sets |(m1,n1)| 9905to the corresponding rounded lattice points, taking the current 9906|octant| into account. Global variable |d1| is also set to 1 if 9907$(x+y+{1\over2})\bmod1\G(y+{1\over2})\bmod1$. 9908 9909@p procedure end_round(@!x,@!y:scaled); 9910begin y:=y+half_unit-y_corr[octant]; 9911x:=x+y-x_corr[octant]; 9912m1:=floor_unscaled(x); n1:=floor_unscaled(y); 9913if x-unity*m1>=y-unity*n1+z_corr[octant] then d1:=1@+else d1:=0; 9914end; 9915 9916@ The outputs |(m1,n1,d1)| of |end_round| will sometimes be moved 9917to |(m0,n0,d0)|. 9918 9919@<Glob...@>= 9920@!m0,@!n0,@!m1,@!n1:integer; {lattice point coordinates} 9921@!d0,@!d1:0..1; {displacement corrections} 9922 9923@ We're ready now to fill the pixels enclosed by a given cycle spec~|h|; 9924the knot list that represents the cycle is destroyed in the process. 9925The edge structure that gets all the resulting data is |cur_edges|, 9926and the edges are weighted by |cur_wt|. 9927 9928@p procedure fill_spec(@!h:pointer); 9929var @!p,@!q,@!r,@!s:pointer; {for list traversal} 9930begin if internal[tracing_edges]>0 then begin_edge_tracing; 9931p:=h; {we assume that |left_type(h)=endpoint|} 9932repeat octant:=left_octant(p); 9933@<Set variable |q| to the node at the end of the current octant@>; 9934if q<>p then 9935 begin @<Determine the starting and ending 9936 lattice points |(m0,n0)| and |(m1,n1)|@>; 9937 @<Make the moves for the current octant@>; 9938 move_to_edges(m0,n0,m1,n1); 9939 end; 9940p:=link(q); 9941until p=h; 9942toss_knot_list(h); 9943if internal[tracing_edges]>0 then end_edge_tracing; 9944end; 9945 9946@ @<Set variable |q| to the node at the end of the current octant@>= 9947q:=p; 9948while right_type(q)<>endpoint do q:=link(q) 9949 9950@ @<Determine the starting and ending lattice points |(m0,n0)| and |(m1,n1)|@>= 9951end_round(x_coord(p),y_coord(p)); m0:=m1; n0:=n1; d0:=d1;@/ 9952end_round(x_coord(q),y_coord(q)) 9953 9954@ Finally we perform the five-step process that was explained at 9955the very beginning of this part of the program. 9956 9957@<Make the moves for the current octant@>= 9958if n1-n0>=move_size then overflow("move table size",move_size); 9959@:METAFONT capacity exceeded move table size}{\quad move table size@> 9960move[0]:=d0; move_ptr:=0; r:=p; 9961repeat s:=link(r);@/ 9962make_moves(x_coord(r),right_x(r),left_x(s),x_coord(s),@| 9963 y_coord(r)+half_unit,right_y(r)+half_unit,left_y(s)+half_unit, 9964 y_coord(s)+half_unit,@| xy_corr[octant],y_corr[octant]); 9965r:=s; 9966until r=q; 9967move[move_ptr]:=move[move_ptr]-d1; 9968if internal[smoothing]>0 then smooth_moves(0,move_ptr) 9969 9970@* \[23] Polygonal pens. 9971The next few parts of the program deal with the additional complications 9972associated with ``envelopes,'' leading up to an algorithm that fills a 9973contour with respect to a pen whose boundary is a convex polygon. The 9974mathematics underlying this algorithm is based on simple aspects of the 9975theory of tracings developed by Leo Guibas, Lyle Ramshaw, and Jorge 9976Stolfi [``A kinetic framework for computational geometry,'' 9977{\sl Proc.\ IEEE Symp.\ Foundations of Computer Science\/ \bf24} (1983), 9978100--111]. 9979@^Guibas, Leonidas Ioannis@> 9980@^Ramshaw, Lyle Harold@> 9981@^Stolfi, Jorge@> 9982 9983If the vertices of the polygon are $w_0$, $w_1$, \dots, $w_{n-1}$, $w_n=w_0$, 9984in counterclockwise order, the convexity condition requires that ``left 9985turns'' are made at each vertex when a person proceeds from $w_0$ to 9986$w_1$ to $\cdots$ to~$w_n$. The envelope is obtained if we offset a given 9987curve $z(t)$ by $w_k$ when that curve is traveling in a direction 9988$z'(t)$ lying between the directions $w_k-w_{k-1}$ and $w\k-w_k$. 9989At times~$t$ when the curve direction $z'(t)$ increases past 9990$w\k-w_k$, we temporarily stop plotting the offset curve and we insert 9991a straight line from $z(t)+w_k$ to $z(t)+w\k$; notice that this straight 9992line is tangent to the offset curve. Similarly, when the curve direction 9993decreases past $w_k-w_{k-1}$, we stop plotting and insert a straight 9994line from $z(t)+w_k$ to $z(t)+w_{k-1}$; the latter line is actually a 9995``retrograde'' step, which won't be part of the final envelope under 9996\MF's assumptions. The result of this construction is a continuous path 9997that consists of alternating curves and straight line segments. The 9998segments are usually so short, in practice, that they blend with the 9999curves; after all, it's possible to represent any digitized path as 10000a sequence of digitized straight lines. 10001 10002The nicest feature of this approach to envelopes is that it blends 10003perfectly with the octant subdivision process we have already developed. 10004The envelope travels in the same direction as the curve itself, as we 10005plot it, and we need merely be careful what offset is being added. 10006Retrograde motion presents a problem, but we will see that there is 10007a decent way to handle it. 10008 10009@ We shall represent pens by maintaining eight lists of offsets, 10010one for each octant direction. The offsets at the boundary points 10011where a curve turns into a new octant will appear in the lists for 10012both octants. This means that we can restrict consideration to 10013segments of the original polygon whose directions aim in the first 10014octant, as we have done in the simpler case when envelopes were not 10015required. 10016 10017An example should help to clarify this situation: Consider the 10018quadrilateral whose vertices are $w_0=(0,-1)$, $w_1=(3,-1)$, 10019$w_2=(6,1)$, and $w_3=(1,2)$. A curve that travels in the first octant 10020will be offset by $w_1$ or $w_2$, unless its slope drops to zero 10021en route to the eighth octant; in the latter case we should switch to $w_0$ as 10022we cross the octant boundary. Our list for the first octant will 10023contain the three offsets $w_0$, $w_1$,~$w_2$. By convention we will 10024duplicate a boundary offset if the angle between octants doesn't 10025explicitly appear; in this case there is no explicit line of slope~1 10026at the end of the list, so the full list is 10027$$w_0\;w_1\;w_2\;w_2\;=\;(0,-1)\;(3,-1)\;(6,1)\;(6,1).$$ 10028With skewed coordinates $(u-v,v)$ instead of $(u,v)$ we obtain the list 10029$$w_0\;w_1\;w_2\;w_2\;\mapsto\;(1,-1)\;(4,-1)\;(5,1)\;(5,1),$$ 10030which is what actually appears in the data structure. In the second 10031octant there's only one offset; we list it twice (with coordinates 10032interchanged, so as to make the second octant look like the first), 10033and skew those coordinates, obtaining 10034$$\tabskip\centering 10035\halign to\hsize{$\hfil#\;\mapsto\;{}$\tabskip=0pt& 10036 $#\hfil$&\quad in the #\hfil\tabskip\centering\cr 10037w_2\;w_2&(-5,6)\;(-5,6)\cr 10038\noalign{\vskip\belowdisplayskip 10039\vbox{\noindent\strut as the list of transformed and skewed offsets to use 10040when curves travel in the second octant. Similarly, we will have\strut} 10041\vskip\abovedisplayskip} 10042w_2\;w_2&(7,-6)\;(7,-6)&third;\cr 10043w_2\;w_2\;w_3\;w_3&(-7,1)\;(-7,1)\;(-3,2)\;(-3,2)&fourth;\cr 10044w_3\;w_3&(1,-2)\;(1,-2)&fifth;\cr 10045w_3\;w_3\;w_0\;w_0&(-1,1)\;(-1,1)\;(1,0)\;(1,0)&sixth;\cr 10046w_0\;w_0&(1,0)\;(1,0)&seventh;\cr 10047w_0\;w_0&(-1,1)\;(-1,1)&eighth.\cr}$$ 10048Notice that $w_1$ is considered here to be internal to the first octant; 10049it's not part of the eighth. We could equally well have taken $w_0$ out 10050of the first octant list and put it into the eighth; then the first octant 10051list would have been 10052$$w_1\;w_1\;w_2\;w_2\;\mapsto\;(4,-1)\;(4,-1)\;(5,1)\;(5,1)$$ 10053and the eighth octant list would have been 10054$$w_0\;w_0\;w_1\;\mapsto\;(-1,1)\;(-1,1)\;(2,1).$$ 10055 10056Actually, there's one more complication: The order of offsets is reversed 10057in even-numbered octants, because the transformation of coordinates has 10058reversed counterclockwise and clockwise orientations in those octants. 10059The offsets in the fourth octant, for example, are really $w_3$, $w_3$, 10060$w_2$,~$w_2$, not $w_2$, $w_2$, $w_3$,~$w_3$. 10061 10062@ In general, the list of offsets for an octant will have the form 10063$$w_0\;\;w_1\;\;\ldots\;\;w_n\;\;w_{n+1}$$ 10064(if we renumber the subscripts in each list), where $w_0$ and $w_{n+1}$ 10065are offsets common to the neighboring lists. We'll often have $w_0=w_1$ 10066and/or $w_n=w_{n+1}$, but the other $w$'s will be distinct. Curves 10067that travel between slope~0 and direction $w_2-w_1$ will use offset~$w_1$; 10068curves that travel between directions $w_k-w_{k-1}$ and $w\k-w_k$ will 10069use offset~$w_k$, for $1<k<n$; curves between direction $w_n-w_{n-1}$ 10070and slope~1 (actually slope~$\infty$ after skewing) will use offset~$w_n$. 10071In even-numbered octants, the directions are actually $w_k-w\k$ instead 10072of $w\k-w_k$, because the offsets have been listed in reverse order. 10073 10074Each offset $w_k$ is represented by skewed coordinates $(u_k-v_k,v_k)$, 10075where $(u_k,v_k)$ is the representation of $w_k$ after it has been rotated 10076into a first-octant disguise. 10077 10078@ The top-level data structure of a pen polygon is a 10-word node containing 10079a reference count followed by pointers to the eight offset lists, followed 10080by an indication of the pen's range of values. 10081@^reference counts@> 10082 10083If |p|~points to such a node, and if the 10084offset list for, say, the fourth octant has entries $w_0$, $w_1$, \dots, 10085$w_n$,~$w_{n+1}$, then |info(p+fourth_octant)| will equal~$n$, and 10086|link(p+fourth_octant)| will point to the offset node containing~$w_0$. 10087Memory location |p+fourth_octant| is said to be the {\sl header\/} of 10088the pen-offset list for the fourth octant. Since this is an even-numbered 10089octant, $w_0$ is the offset that goes with the fifth octant, and 10090$w_{n+1}$ goes with the third. 10091 10092The elements of the offset list themselves are doubly linked 3-word nodes, 10093containing coordinates in their |x_coord| and |y_coord| fields. 10094The two link fields are called |link| and |knil|; if |w|~points to 10095the node for~$w_k$, then |link(w)| and |knil(w)| point respectively 10096to the nodes for $w\k$ and~$w_{k-1}$. If |h| is the list header, 10097|link(h)| points to the node for~$w_0$ and |knil(link(h))| to the 10098node for~$w_{n+1}$. 10099 10100The tenth word of a pen header node contains the maximum absolute value of 10101an $x$ or $y$ coordinate among all of the unskewed pen offsets. 10102 10103The |link| field of a pen header node should be |null| if and only if 10104the pen is a single point. 10105 10106@d pen_node_size=10 10107@d coord_node_size=3 10108@d max_offset(#)==mem[#+9].sc 10109 10110@ The |print_pen| subroutine illustrates these conventions by 10111reconstructing the vertices of a polygon from \MF's complicated 10112internal offset representation. 10113 10114@<Declare subroutines for printing expressions@>= 10115procedure print_pen(@!p:pointer;@!s:str_number;@!nuline:boolean); 10116var @!nothing_printed:boolean; {has there been any action yet?} 10117@!k:1..8; {octant number} 10118@!h:pointer; {offset list head} 10119@!m,@!n:integer; {offset indices} 10120@!w,@!ww:pointer; {pointers that traverse the offset list} 10121begin print_diagnostic("Pen polygon",s,nuline); 10122nothing_printed:=true; print_ln; 10123for k:=1 to 8 do 10124 begin octant:=octant_code[k]; h:=p+octant; n:=info(h); w:=link(h); 10125 if not odd(k) then w:=knil(w); {in even octants, start at $w_{n+1}$} 10126 for m:=1 to n+1 do 10127 begin if odd(k) then ww:=link(w)@+else ww:=knil(w); 10128 if (x_coord(ww)<>x_coord(w))or(y_coord(ww)<>y_coord(w)) then 10129 @<Print the unskewed and unrotated coordinates of node |ww|@>; 10130 w:=ww; 10131 end; 10132 end; 10133if nothing_printed then 10134 begin w:=link(p+first_octant); print_two(x_coord(w)+y_coord(w),y_coord(w)); 10135 end; 10136print_nl(" .. cycle"); end_diagnostic(true); 10137end; 10138 10139@ @<Print the unskewed and unrotated coordinates of node |ww|@>= 10140begin if nothing_printed then nothing_printed:=false 10141else print_nl(" .. "); 10142print_two_true(x_coord(ww),y_coord(ww)); 10143end 10144 10145@ A null pen polygon, which has just one vertex $(0,0)$, is 10146predeclared for error recovery. It doesn't need a proper 10147reference count, because the |toss_pen| procedure below 10148will never delete it from memory. 10149@^reference counts@> 10150 10151@<Initialize table entries...@>= 10152ref_count(null_pen):=null; link(null_pen):=null;@/ 10153info(null_pen+1):=1; link(null_pen+1):=null_coords; 10154for k:=null_pen+2 to null_pen+8 do mem[k]:=mem[null_pen+1]; 10155max_offset(null_pen):=0;@/ 10156link(null_coords):=null_coords; 10157knil(null_coords):=null_coords;@/ 10158x_coord(null_coords):=0; 10159y_coord(null_coords):=0; 10160 10161@ Here's a trivial subroutine that inserts a copy of an offset 10162on the |link| side of its clone in the doubly linked list. 10163 10164@p procedure dup_offset(@!w:pointer); 10165var @!r:pointer; {the new node} 10166begin r:=get_node(coord_node_size); 10167x_coord(r):=x_coord(w); 10168y_coord(r):=y_coord(w); 10169link(r):=link(w); knil(link(w)):=r; 10170knil(r):=w; link(w):=r; 10171end; 10172 10173@ The following algorithm is somewhat more interesting: It converts a 10174knot list for a cyclic path into a pen polygon, ignoring everything 10175but the |x_coord|, |y_coord|, and |link| fields. If the given path 10176vertices do not define a convex polygon, an error message is issued 10177and the null pen is returned. 10178 10179@p function make_pen(@!h:pointer):pointer; 10180label done,done1,not_found,found; 10181var @!o,@!oo,@!k:small_number; {octant numbers---old, new, and current} 10182@!p:pointer; {top-level node for the new pen} 10183@!q,@!r,@!s,@!w,@!hh:pointer; {for list manipulation} 10184@!n:integer; {offset counter} 10185@!dx,@!dy:scaled; {polygon direction} 10186@!mc:scaled; {the largest coordinate} 10187begin @<Stamp all nodes with an octant code, compute the maximum offset, 10188 and set |hh| to the node that begins the first octant; 10189 |goto not_found| if there's a problem@>; 10190if mc>=fraction_one-half_unit then goto not_found; 10191p:=get_node(pen_node_size); q:=hh; max_offset(p):=mc; ref_count(p):=null; 10192if link(q)<>q then link(p):=null+1; 10193for k:=1 to 8 do @<Construct the offset list for the |k|th octant@>; 10194goto found; 10195not_found:p:=null_pen; @<Complain about a bad pen path@>; 10196found: if internal[tracing_pens]>0 then print_pen(p," (newly created)",true); 10197make_pen:=p; 10198end; 10199 10200@ @<Complain about a bad pen path@>= 10201if mc>=fraction_one-half_unit then 10202 begin print_err("Pen too large"); 10203@.Pen too large@> 10204 help2("The cycle you specified has a coordinate of 4095.5 or more.")@/ 10205 ("So I've replaced it by the trivial path `(0,0)..cycle'.");@/ 10206 end 10207else begin print_err("Pen cycle must be convex"); 10208@.Pen cycle must be convex@> 10209 help3("The cycle you specified either has consecutive equal points")@/ 10210 ("or turns right or turns through more than 360 degrees.")@/ 10211 ("So I've replaced it by the trivial path `(0,0)..cycle'.");@/ 10212 end; 10213put_get_error 10214 10215@ There should be exactly one node whose octant number is less than its 10216predecessor in the cycle; that is node~|hh|. 10217 10218The loop here will terminate in all cases, but the proof is somewhat tricky: 10219If there are at least two distinct $y$~coordinates in the cycle, we will have 10220|o>4| and |o<=4| at different points of the cycle. Otherwise there are 10221at least two distinct $x$~coordinates, and we will have |o>2| somewhere, 10222|o<=2| somewhere. 10223 10224@<Stamp all nodes...@>= 10225q:=h; r:=link(q); mc:=abs(x_coord(h)); 10226if q=r then 10227 begin hh:=h; right_type(h):=0; {this trick is explained below} 10228 if mc<abs(y_coord(h)) then mc:=abs(y_coord(h)); 10229 end 10230else begin o:=0; hh:=null; 10231 loop@+ begin s:=link(r); 10232 if mc<abs(x_coord(r)) then mc:=abs(x_coord(r)); 10233 if mc<abs(y_coord(r)) then mc:=abs(y_coord(r)); 10234 dx:=x_coord(r)-x_coord(q); dy:=y_coord(r)-y_coord(q); 10235 if dx=0 then if dy=0 then goto not_found; {double point} 10236 if ab_vs_cd(dx,y_coord(s)-y_coord(r),dy,x_coord(s)-x_coord(r))<0 then 10237 goto not_found; {right turn} 10238 @<Determine the octant code for direction |(dx,dy)|@>; 10239 right_type(q):=octant; oo:=octant_number[octant]; 10240 if o>oo then 10241 begin if hh<>null then goto not_found; {$>360^\circ$} 10242 hh:=q; 10243 end; 10244 o:=oo; 10245 if (q=h)and(hh<>null) then goto done; 10246 q:=r; r:=s; 10247 end; 10248 done:end 10249 10250 10251@ We want the octant for |(-dx,-dy)| to be 10252exactly opposite the octant for |(dx,dy)|. 10253 10254@<Determine the octant code for direction |(dx,dy)|@>= 10255if dx>0 then octant:=first_octant 10256else if dx=0 then 10257 if dy>0 then octant:=first_octant@+else octant:=first_octant+negate_x 10258else begin negate(dx); octant:=first_octant+negate_x; 10259 end; 10260if dy<0 then 10261 begin negate(dy); octant:=octant+negate_y; 10262 end 10263else if dy=0 then 10264 if octant>first_octant then octant:=first_octant+negate_x+negate_y; 10265if dx<dy then octant:=octant+switch_x_and_y 10266 10267@ Now |q| points to the node that the present octant shares with the previous 10268octant, and |right_type(q)| is the octant code during which |q|~should advance. 10269We have set |right_type(q)=0| in the special case that |q| should never advance 10270(because the pen is degenerate). 10271 10272The number of offsets |n| must be smaller than |max_quarterword|, because 10273the |fill_envelope| routine stores |n+1| in the |right_type| field 10274of a knot node. 10275 10276@<Construct the offset list...@>= 10277begin octant:=octant_code[k]; n:=0; h:=p+octant; 10278loop@+ begin r:=get_node(coord_node_size); 10279 skew(x_coord(q),y_coord(q),octant); x_coord(r):=cur_x; y_coord(r):=cur_y; 10280 if n=0 then link(h):=r 10281 else @<Link node |r| to the previous node@>; 10282 w:=r; 10283 if right_type(q)<>octant then goto done1; 10284 q:=link(q); incr(n); 10285 end; 10286done1: @<Finish linking the offset nodes, and duplicate the 10287 borderline offset nodes if necessary@>; 10288if n>=max_quarterword then overflow("pen polygon size",max_quarterword); 10289@:METAFONT capacity exceeded pen polygon size}{\quad pen polygon size@> 10290info(h):=n; 10291end 10292 10293@ Now |w| points to the node that was inserted most recently, and 10294|k| is the current octant number. 10295 10296@<Link node |r| to the previous node@>= 10297if odd(k) then 10298 begin link(w):=r; knil(r):=w; 10299 end 10300else begin knil(w):=r; link(r):=w; 10301 end 10302 10303@ We have inserted |n+1| nodes; it remains to duplicate the nodes at the 10304ends, if slopes 0 and~$\infty$ aren't already represented. At the end of 10305this section the total number of offset nodes should be |n+2| 10306(since we call them $w_0$, $w_1$, \dots,~$w_{n+1}$). 10307 10308@<Finish linking the offset nodes, and duplicate...@>= 10309r:=link(h); 10310if odd(k) then 10311 begin link(w):=r; knil(r):=w; 10312 end 10313else begin knil(w):=r; link(r):=w; link(h):=w; r:=w; 10314 end; 10315if (y_coord(r)<>y_coord(link(r)))or(n=0) then 10316 begin dup_offset(r); incr(n); 10317 end; 10318r:=knil(r); 10319if x_coord(r)<>x_coord(knil(r)) then dup_offset(r) 10320else decr(n) 10321 10322@ Conversely, |make_path| goes back from a pen to a cyclic path that 10323might have generated it. The structure of this subroutine is essentially 10324the same as |print_pen|. 10325 10326@p @t\4@>@<Declare the function called |trivial_knot|@>@; 10327function make_path(@!pen_head:pointer):pointer; 10328var @!p:pointer; {the most recently copied knot} 10329@!k:1..8; {octant number} 10330@!h:pointer; {offset list head} 10331@!m,@!n:integer; {offset indices} 10332@!w,@!ww:pointer; {pointers that traverse the offset list} 10333begin p:=temp_head; 10334for k:=1 to 8 do 10335 begin octant:=octant_code[k]; h:=pen_head+octant; n:=info(h); w:=link(h); 10336 if not odd(k) then w:=knil(w); {in even octants, start at $w_{n+1}$} 10337 for m:=1 to n+1 do 10338 begin if odd(k) then ww:=link(w)@+else ww:=knil(w); 10339 if (x_coord(ww)<>x_coord(w))or(y_coord(ww)<>y_coord(w)) then 10340 @<Copy the unskewed and unrotated coordinates of node |ww|@>; 10341 w:=ww; 10342 end; 10343 end; 10344if p=temp_head then 10345 begin w:=link(pen_head+first_octant); 10346 p:=trivial_knot(x_coord(w)+y_coord(w),y_coord(w)); link(temp_head):=p; 10347 end; 10348link(p):=link(temp_head); make_path:=link(temp_head); 10349end; 10350 10351@ @<Copy the unskewed and unrotated coordinates of node |ww|@>= 10352begin unskew(x_coord(ww),y_coord(ww),octant); 10353link(p):=trivial_knot(cur_x,cur_y); p:=link(p); 10354end 10355 10356@ @<Declare the function called |trivial_knot|@>= 10357function trivial_knot(@!x,@!y:scaled):pointer; 10358var @!p:pointer; {a new knot for explicit coordinates |x| and |y|} 10359begin p:=get_node(knot_node_size); 10360left_type(p):=explicit; right_type(p):=explicit;@/ 10361x_coord(p):=x; left_x(p):=x; right_x(p):=x;@/ 10362y_coord(p):=y; left_y(p):=y; right_y(p):=y;@/ 10363trivial_knot:=p; 10364end; 10365 10366@ That which can be created can be destroyed. 10367 10368@d add_pen_ref(#)==incr(ref_count(#)) 10369@d delete_pen_ref(#)==if ref_count(#)=null then toss_pen(#) 10370 else decr(ref_count(#)) 10371 10372@<Declare the recycling subroutines@>= 10373procedure toss_pen(@!p:pointer); 10374var @!k:1..8; {relative header locations} 10375@!w,@!ww:pointer; {pointers to offset nodes} 10376begin if p<>null_pen then 10377 begin for k:=1 to 8 do 10378 begin w:=link(p+k); 10379 repeat ww:=link(w); free_node(w,coord_node_size); w:=ww; 10380 until w=link(p+k); 10381 end; 10382 free_node(p,pen_node_size); 10383 end; 10384end; 10385 10386@ The |find_offset| procedure sets |(cur_x,cur_y)| to the offset associated 10387with a given direction~|(x,y)| and a given pen~|p|. If |x=y=0|, the 10388result is |(0,0)|. If two different offsets apply, one of them is 10389chosen arbitrarily. 10390 10391@p procedure find_offset(@!x,@!y:scaled; @!p:pointer); 10392label done,exit; 10393var @!octant:first_octant..sixth_octant; {octant code for |(x,y)|} 10394@!s:-1..+1; {sign of the octant} 10395@!n:integer; {number of offsets remaining} 10396@!h,@!w,@!ww:pointer; {list traversal registers} 10397begin @<Compute the octant code; skew and rotate the coordinates |(x,y)|@>; 10398if odd(octant_number[octant]) then s:=-1@+else s:=+1; 10399h:=p+octant; w:=link(link(h)); ww:=link(w); n:=info(h); 10400while n>1 do 10401 begin if ab_vs_cd(x,y_coord(ww)-y_coord(w),@| 10402 y,x_coord(ww)-x_coord(w))<>s then goto done; 10403 w:=ww; ww:=link(w); decr(n); 10404 end; 10405done:unskew(x_coord(w),y_coord(w),octant); 10406exit:end; 10407 10408@ @<Compute the octant code; skew and rotate the coordinates |(x,y)|@>= 10409if x>0 then octant:=first_octant 10410else if x=0 then 10411 if y<=0 then 10412 if y=0 then 10413 begin cur_x:=0; cur_y:=0; return; 10414 end 10415 else octant:=first_octant+negate_x 10416 else octant:=first_octant 10417else begin x:=-x; 10418 if y=0 then octant:=first_octant+negate_x+negate_y 10419 else octant:=first_octant+negate_x; 10420 end; 10421if y<0 then 10422 begin octant:=octant+negate_y; y:=-y; 10423 end; 10424if x>=y then x:=x-y 10425else begin octant:=octant+switch_x_and_y; x:=y-x; y:=y-x; 10426 end 10427 10428@* \[24] Filling an envelope. 10429We are about to reach the culmination of \MF's digital plotting routines: 10430Almost all of the previous algorithms will be brought to bear on \MF's 10431most difficult task, which is to fill the envelope of a given cyclic path 10432with respect to a given pen polygon. 10433 10434But we still must complete some of the preparatory work before taking such 10435a big plunge. 10436 10437@ Given a pointer |c| to a nonempty list of cubics, 10438and a pointer~|h| to the header information of a pen polygon segment, 10439the |offset_prep| routine changes the list into cubics that are 10440associated with particular pen offsets. Namely, the cubic between |p| 10441and~|q| should be associated with the |k|th offset when |right_type(p)=k|. 10442 10443List |c| is actually part of a cycle spec, so it terminates at the 10444first node whose |right_type| is |endpoint|. The cubics all have 10445monotone-nondecreasing $x(t)$ and $y(t)$. 10446 10447@p @t\4@>@<Declare subroutines needed by |offset_prep|@>@; 10448procedure offset_prep(@!c,@!h:pointer); 10449label done,not_found; 10450var @!n:halfword; {the number of pen offsets} 10451@!p,@!q,@!r,@!lh,@!ww:pointer; {for list manipulation} 10452@!k:halfword; {the current offset index} 10453@!w:pointer; {a pointer to offset $w_k$} 10454@<Other local variables for |offset_prep|@>@; 10455begin p:=c; n:=info(h); lh:=link(h); {now |lh| points to $w_0$} 10456while right_type(p)<>endpoint do 10457 begin q:=link(p); 10458 @<Split the cubic between |p| and |q|, if necessary, into cubics 10459 associated with single offsets, after which |q| should 10460 point to the end of the final such cubic@>; 10461 @<Advance |p| to node |q|, removing any ``dead'' cubics that 10462 might have been introduced by the splitting process@>; 10463 end; 10464end; 10465 10466@ @<Advance |p| to node |q|, removing any ``dead'' cubics...@>= 10467repeat r:=link(p); 10468if x_coord(p)=right_x(p) then if y_coord(p)=right_y(p) then 10469 if x_coord(p)=left_x(r) then if y_coord(p)=left_y(r) then 10470 if x_coord(p)=x_coord(r) then if y_coord(p)=y_coord(r) then 10471 begin remove_cubic(p); 10472 if r=q then q:=p; 10473 r:=p; 10474 end; 10475p:=r; 10476until p=q 10477 10478@ The splitting process uses a subroutine like |split_cubic|, but 10479(for ``bulletproof'' operation) we check to make sure that the 10480resulting (skewed) coordinates satisfy $\Delta x\G0$ and $\Delta y\G0$ 10481after splitting; |make_spec| has made sure that these relations hold 10482before splitting. (This precaution is surely unnecessary, now that 10483|make_spec| is so much more careful than it used to be. But who 10484wants to take a chance? Maybe the hardware will fail or something.) 10485 10486@<Declare subroutines needed by |offset_prep|@>= 10487procedure split_for_offset(@!p:pointer;@!t:fraction); 10488var @!q:pointer; {the successor of |p|} 10489@!r:pointer; {the new node} 10490begin q:=link(p); split_cubic(p,t,x_coord(q),y_coord(q)); r:=link(p); 10491if y_coord(r)<y_coord(p) then y_coord(r):=y_coord(p) 10492else if y_coord(r)>y_coord(q) then y_coord(r):=y_coord(q); 10493if x_coord(r)<x_coord(p) then x_coord(r):=x_coord(p) 10494else if x_coord(r)>x_coord(q) then x_coord(r):=x_coord(q); 10495end; 10496 10497@ If the pen polygon has |n| offsets, and if $w_k=(u_k,v_k)$ is the $k$th 10498of these, the $k$th pen slope is defined by the formula 10499$$s_k={v\k-v_k\over u\k-u_k},\qquad\hbox{for $0<k<n$}.$$ 10500In odd-numbered octants, the numerator and denominator of this fraction 10501will be nonnegative; in even-numbered octants they will both be nonpositive. 10502Furthermore we always have $0=s_0\le s_1\le\cdots\le s_n=\infty$. The goal of 10503|offset_prep| is to find an offset index~|k| to associate with 10504each cubic, such that the slope $s(t)$ of the cubic satisfies 10505$$s_{k-1}\le s(t)\le s_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$ 10506We may have to split a cubic into as many as $2n-1$ pieces before each 10507piece corresponds to a unique offset. 10508 10509@<Split the cubic between |p| and |q|, if necessary, into cubics...@>= 10510if n<=1 then right_type(p):=1 {this case is easy} 10511else begin @<Prepare for derivative computations; 10512 |goto not_found| if the current cubic is dead@>; 10513 @<Find the initial slope, |dy/dx|@>; 10514 if dx=0 then @<Handle the special case of infinite slope@> 10515 else begin @<Find the index |k| such that $s_{k-1}\L\\{dy}/\\{dx}<s_k$@>; 10516 @<Complete the offset splitting process@>; 10517 end; 10518not_found: end 10519 10520@ The slope of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be 10521calculated from the quadratic polynomials 10522${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and 10523${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$. 10524Since we may be calculating slopes from several cubics 10525split from the current one, it is desirable to do these calculations 10526without losing too much precision. ``Scaled up'' values of the 10527derivatives, which will be less tainted by accumulated errors than 10528derivatives found from the cubics themselves, are maintained in 10529local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$, 10530$X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2| 10531represent $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)$. 10532To test whether the slope of the cubic is $\ge s$ or $\le s$, we will test 10533the sign of the quadratic ${1\over3}2^l\bigl(y'(t)-sx'(t)\bigr)$ if $s\le1$, 10534or ${1\over3}2^l\bigl(y'(t)/s-x'(t)\bigr)$ if $s>1$. 10535 10536@<Other local variables for |offset_prep|@>= 10537@!x0,@!x1,@!x2,@!y0,@!y1,@!y2:integer; {representatives of derivatives} 10538@!t0,@!t1,@!t2:integer; {coefficients of polynomial for slope testing} 10539@!du,@!dv,@!dx,@!dy:integer; {for slopes of the pen and the curve} 10540@!max_coef:integer; {used while scaling} 10541@!x0a,@!x1a,@!x2a,@!y0a,@!y1a,@!y2a:integer; {intermediate values} 10542@!t:fraction; {where the derivative passes through zero} 10543@!s:fraction; {slope or reciprocal slope} 10544 10545@ @<Prepare for derivative computations...@>= 10546x0:=right_x(p)-x_coord(p); {should be |>=0|} 10547x2:=x_coord(q)-left_x(q); {likewise} 10548x1:=left_x(q)-right_x(p); {but this might be negative} 10549y0:=right_y(p)-y_coord(p); y2:=y_coord(q)-left_y(q); 10550y1:=left_y(q)-right_y(p); 10551max_coef:=abs(x0); {we take |abs| just to make sure} 10552if abs(x1)>max_coef then max_coef:=abs(x1); 10553if abs(x2)>max_coef then max_coef:=abs(x2); 10554if abs(y0)>max_coef then max_coef:=abs(y0); 10555if abs(y1)>max_coef then max_coef:=abs(y1); 10556if abs(y2)>max_coef then max_coef:=abs(y2); 10557if max_coef=0 then goto not_found; 10558while max_coef<fraction_half do 10559 begin double(max_coef); 10560 double(x0); double(x1); double(x2); 10561 double(y0); double(y1); double(y2); 10562 end 10563 10564@ Let us first solve a special case of the problem: Suppose we 10565know an index~$k$ such that either (i)~$s(t)\G s_{k-1}$ for all~$t$ 10566and $s(0)<s_k$, or (ii)~$s(t)\L s_k$ for all~$t$ and $s(0)>s_{k-1}$. 10567Then, in a sense, we're halfway done, since one of the two inequalities 10568in $(*)$ is satisfied, and the other couldn't be satisfied for 10569any other value of~|k|. 10570 10571The |fin_offset_prep| subroutine solves the stated subproblem. 10572It has a boolean parameter called |rising| that is |true| in 10573case~(i), |false| in case~(ii). When |rising=false|, parameters 10574|x0| through |y2| represent the negative of the derivative of 10575the cubic following |p|; otherwise they represent the actual derivative. 10576The |w| parameter should point to offset~$w_k$. 10577 10578@<Declare subroutines needed by |offset_prep|@>= 10579procedure fin_offset_prep(@!p:pointer;@!k:halfword;@!w:pointer; 10580 @!x0,@!x1,@!x2,@!y0,@!y1,@!y2:integer;@!rising:boolean;@!n:integer); 10581label exit; 10582var @!ww:pointer; {for list manipulation} 10583@!du,@!dv:scaled; {for slope calculation} 10584@!t0,@!t1,@!t2:integer; {test coefficients} 10585@!t:fraction; {place where the derivative passes a critical slope} 10586@!s:fraction; {slope or reciprocal slope} 10587@!v:integer; {intermediate value for updating |x0..y2|} 10588begin loop 10589 begin right_type(p):=k; 10590 if rising then 10591 if k=n then return 10592 else ww:=link(w) {a pointer to $w\k$} 10593 else if k=1 then return 10594 else ww:=knil(w); {a pointer to $w_{k-1}$} 10595 @<Compute test coefficients |(t0,t1,t2)| 10596 for $s(t)$ versus $s_k$ or $s_{k-1}$@>; 10597 t:=crossing_point(t0,t1,t2); 10598 if t>=fraction_one then return; 10599 @<Split the cubic at $t$, 10600 and split off another cubic if the derivative crosses back@>; 10601 if rising then incr(k)@+else decr(k); 10602 w:=ww; 10603 end; 10604exit:end; 10605 10606@ @<Compute test coefficients |(t0,t1,t2)| for $s(t)$ versus...@>= 10607du:=x_coord(ww)-x_coord(w); dv:=y_coord(ww)-y_coord(w); 10608if abs(du)>=abs(dv) then {$s_{k-1}\le1$ or $s_k\le1$} 10609 begin s:=make_fraction(dv,du); 10610 t0:=take_fraction(x0,s)-y0; 10611 t1:=take_fraction(x1,s)-y1; 10612 t2:=take_fraction(x2,s)-y2; 10613 end 10614else begin s:=make_fraction(du,dv); 10615 t0:=x0-take_fraction(y0,s); 10616 t1:=x1-take_fraction(y1,s); 10617 t2:=x2-take_fraction(y2,s); 10618 end 10619 10620@ The curve has crossed $s_k$ or $s_{k-1}$; its initial segment satisfies 10621$(*)$, and it might cross again and return towards $s_{k-1}$ or $s_k$, 10622respectively, yielding another solution of $(*)$. 10623 10624@<Split the cubic at $t$, and split off another...@>= 10625begin split_for_offset(p,t); right_type(p):=k; p:=link(p);@/ 10626v:=t_of_the_way(x0)(x1); x1:=t_of_the_way(x1)(x2); 10627x0:=t_of_the_way(v)(x1);@/ 10628v:=t_of_the_way(y0)(y1); y1:=t_of_the_way(y1)(y2); 10629y0:=t_of_the_way(v)(y1);@/ 10630t1:=t_of_the_way(t1)(t2); 10631if t1>0 then t1:=0; {without rounding error, |t1| would be |<=0|} 10632t:=crossing_point(0,-t1,-t2); 10633if t<fraction_one then 10634 begin split_for_offset(p,t); right_type(link(p)):=k;@/ 10635 v:=t_of_the_way(x1)(x2); x1:=t_of_the_way(x0)(x1); 10636 x2:=t_of_the_way(x1)(v);@/ 10637 v:=t_of_the_way(y1)(y2); y1:=t_of_the_way(y0)(y1); 10638 y2:=t_of_the_way(y1)(v); 10639 end; 10640end 10641 10642@ Now we must consider the general problem of |offset_prep|, when 10643nothing is known about a given cubic. We start by finding its 10644slope $s(0)$ in the vicinity of |t=0|. 10645 10646If $z'(t)=0$, the given cubic is numerically unstable, since the 10647slope direction is probably being influenced primarily by rounding 10648errors. A user who specifies such cuspy curves should expect to generate 10649rather wild results. The present code tries its best to believe the 10650existing data, as if no rounding errors were present. 10651 10652@ @<Find the initial slope, |dy/dx|@>= 10653dx:=x0; dy:=y0; 10654if dx=0 then if dy=0 then 10655 begin dx:=x1; dy:=y1; 10656 if dx=0 then if dy=0 then 10657 begin dx:=x2; dy:=y2; 10658 end; 10659 end 10660 10661@ The next step is to bracket the initial slope between consecutive 10662slopes of the pen polygon. The most important invariant relation in the 10663following loop is that |dy/dx>=@t$s_{k-1}$@>|. 10664 10665@<Find the index |k| such that $s_{k-1}\L\\{dy}/\\{dx}<s_k$@>= 10666k:=1; w:=link(lh); 10667loop@+ begin if k=n then goto done; 10668 ww:=link(w); 10669 if ab_vs_cd(dy,abs(x_coord(ww)-x_coord(w)),@| 10670 dx,abs(y_coord(ww)-y_coord(w)))>=0 then 10671 begin incr(k); w:=ww; 10672 end 10673 else goto done; 10674 end; 10675done: 10676 10677@ Finally we want to reduce the general problem to situations that 10678|fin_offset_prep| can handle. If |k=1|, we already are in the desired 10679situation. Otherwise we can split the cubic into at most three parts 10680with respect to $s_{k-1}$, and apply |fin_offset_prep| to each part. 10681 10682@<Complete the offset splitting process@>= 10683if k=1 then t:=fraction_one+1 10684else begin ww:=knil(w); @<Compute test coeff...@>; 10685 t:=crossing_point(-t0,-t1,-t2); 10686 end; 10687if t>=fraction_one then fin_offset_prep(p,k,w,x0,x1,x2,y0,y1,y2,true,n) 10688else begin split_for_offset(p,t); r:=link(p);@/ 10689 x1a:=t_of_the_way(x0)(x1); x1:=t_of_the_way(x1)(x2); 10690 x2a:=t_of_the_way(x1a)(x1);@/ 10691 y1a:=t_of_the_way(y0)(y1); y1:=t_of_the_way(y1)(y2); 10692 y2a:=t_of_the_way(y1a)(y1);@/ 10693 fin_offset_prep(p,k,w,x0,x1a,x2a,y0,y1a,y2a,true,n); x0:=x2a; y0:=y2a; 10694 t1:=t_of_the_way(t1)(t2); 10695 if t1<0 then t1:=0; 10696 t:=crossing_point(0,t1,t2); 10697 if t<fraction_one then 10698 @<Split off another |rising| cubic for |fin_offset_prep|@>; 10699 fin_offset_prep(r,k-1,ww,-x0,-x1,-x2,-y0,-y1,-y2,false,n); 10700 end 10701 10702@ @<Split off another |rising| cubic for |fin_offset_prep|@>= 10703begin split_for_offset(r,t);@/ 10704x1a:=t_of_the_way(x1)(x2); x1:=t_of_the_way(x0)(x1); 10705x0a:=t_of_the_way(x1)(x1a);@/ 10706y1a:=t_of_the_way(y1)(y2); y1:=t_of_the_way(y0)(y1); 10707y0a:=t_of_the_way(y1)(y1a);@/ 10708fin_offset_prep(link(r),k,w,x0a,x1a,x2,y0a,y1a,y2,true,n); 10709x2:=x0a; y2:=y0a; 10710end 10711 10712@ @<Handle the special case of infinite slope@>= 10713fin_offset_prep(p,n,knil(knil(lh)),-x0,-x1,-x2,-y0,-y1,-y2,false,n) 10714 10715@ OK, it's time now for the biggie. The |fill_envelope| routine generalizes 10716|fill_spec| to polygonal envelopes. Its outer structure is essentially the 10717same as before, except that octants with no cubics do contribute to 10718the envelope. 10719 10720@p @t\4@>@<Declare the procedure called |skew_line_edges|@>@; 10721@t\4@>@<Declare the procedure called |dual_moves|@>@; 10722procedure fill_envelope(@!spec_head:pointer); 10723label done, done1; 10724var @!p,@!q,@!r,@!s:pointer; {for list traversal} 10725@!h:pointer; {head of pen offset list for current octant} 10726@!www:pointer; {a pen offset of temporary interest} 10727@<Other local variables for |fill_envelope|@>@; 10728begin if internal[tracing_edges]>0 then begin_edge_tracing; 10729p:=spec_head; {we assume that |left_type(spec_head)=endpoint|} 10730repeat octant:=left_octant(p); h:=cur_pen+octant; 10731@<Set variable |q| to the node at the end of the current octant@>; 10732@<Determine the envelope's starting and ending 10733 lattice points |(m0,n0)| and |(m1,n1)|@>; 10734offset_prep(p,h); {this may clobber node~|q|, if it becomes ``dead''} 10735@<Set variable |q| to the node at the end of the current octant@>; 10736@<Make the envelope moves for the current octant and insert them 10737 in the pixel data@>; 10738p:=link(q); 10739until p=spec_head; 10740if internal[tracing_edges]>0 then end_edge_tracing; 10741toss_knot_list(spec_head); 10742end; 10743 10744@ In even-numbered octants we have reflected the coordinates an odd number 10745of times, hence clockwise and counterclockwise are reversed; this means that 10746the envelope is being formed in a ``dual'' manner. For the time being, let's 10747concentrate on odd-numbered octants, since they're easier to understand. 10748After we have coded the program for odd-numbered octants, the changes needed 10749to dualize it will not be so mysterious. 10750 10751It is convenient to assume that we enter an odd-numbered octant with 10752an |axis| transition (where the skewed slope is zero) and leave at a 10753|diagonal| one (where the skewed slope is infinite). Then all of the 10754offset points $z(t)+w(t)$ will lie in a rectangle whose lower left and 10755upper right corners are the initial and final offset points. If this 10756assumption doesn't hold we can implicitly change the curve so that it does. 10757For example, if the entering transition is diagonal, we can draw a 10758straight line from $z_0+w_{n+1}$ to $z_0+w_0$ and continue as if the 10759curve were moving rightward. The effect of this on the envelope is simply 10760to ``doubly color'' the region enveloped by a section of the pen that 10761goes from $w_0$ to $w_1$ to $\cdots$ to $w_{n+1}$ to~$w_0$. The additional 10762straight line at the beginning (and a similar one at the end, where it 10763may be necessary to go from $z_1+w_{n+1}$ to $z_1+w_0$) can be drawn by 10764the |line_edges| routine; we are thereby saved from the embarrassment that 10765these lines travel backwards from the current octant direction. 10766 10767Once we have established the assumption that the curve goes from 10768$z_0+w_0$ to $z_1+w_{n+1}$, any further retrograde moves that might 10769occur within the octant can be essentially ignored; we merely need to 10770keep track of the rightmost edge in each row, in order to compute 10771the envelope. 10772 10773Envelope moves consist of offset cubics intermixed with straight line 10774segments. We record them in a separate |env_move| array, which is 10775something like |move| but it keeps track of the rightmost position of the 10776envelope in each row. 10777 10778@<Glob...@>= 10779@!env_move:array[0..move_size] of integer; 10780 10781@ @<Determine the envelope's starting and ending...@>= 10782w:=link(h);@+if left_transition(p)=diagonal then w:=knil(w); 10783@!stat if internal[tracing_edges]>unity then 10784 @<Print a line of diagnostic info to introduce this octant@>; 10785tats@;@/ 10786ww:=link(h); www:=ww; {starting and ending offsets} 10787if odd(octant_number[octant]) then www:=knil(www)@+else ww:=knil(ww); 10788if w<>ww then skew_line_edges(p,w,ww); 10789end_round(x_coord(p)+x_coord(ww),y_coord(p)+y_coord(ww)); 10790m0:=m1; n0:=n1; d0:=d1;@/ 10791end_round(x_coord(q)+x_coord(www),y_coord(q)+y_coord(www)); 10792if n1-n0>=move_size then overflow("move table size",move_size) 10793@:METAFONT capacity exceeded move table size}{\quad move table size@> 10794 10795@ @<Print a line of diagnostic info to introduce this octant@>= 10796begin print_nl("@@ Octant "); print(octant_dir[octant]); 10797@:]]]\AT!_Octant}{\.{\AT! Octant...}@> 10798print(" ("); print_int(info(h)); print(" offset"); 10799if info(h)<>1 then print_char("s"); 10800print("), from "); 10801print_two_true(x_coord(p)+x_coord(w),y_coord(p)+y_coord(w));@/ 10802ww:=link(h);@+if right_transition(q)=diagonal then ww:=knil(ww); 10803print(" to "); 10804print_two_true(x_coord(q)+x_coord(ww),y_coord(q)+y_coord(ww)); 10805end 10806 10807@ A slight variation of the |line_edges| procedure comes in handy 10808when we must draw the retrograde lines for nonstandard entry and exit 10809conditions. 10810 10811@<Declare the procedure called |skew_line_edges|@>= 10812procedure skew_line_edges(@!p,@!w,@!ww:pointer); 10813var @!x0,@!y0,@!x1,@!y1:scaled; {from and to} 10814begin if (x_coord(w)<>x_coord(ww))or(y_coord(w)<>y_coord(ww)) then 10815 begin x0:=x_coord(p)+x_coord(w); y0:=y_coord(p)+y_coord(w);@/ 10816 x1:=x_coord(p)+x_coord(ww); y1:=y_coord(p)+y_coord(ww);@/ 10817 unskew(x0,y0,octant); {unskew and unrotate the coordinates} 10818 x0:=cur_x; y0:=cur_y;@/ 10819 unskew(x1,y1,octant);@/ 10820 @!stat if internal[tracing_edges]>unity then 10821 begin print_nl("@@ retrograde line from "); 10822@:]]]\AT!_retro_}{\.{\AT! retrograde line...}@> 10823 @.retrograde line...@> 10824 print_two(x0,y0); print(" to "); print_two(cur_x,cur_y); print_nl(""); 10825 end;@+tats@;@/ 10826 line_edges(x0,y0,cur_x,cur_y); {then draw a straight line} 10827 end; 10828end; 10829 10830@ The envelope calculations require more local variables than we needed 10831in the simpler case of |fill_spec|. At critical points in the computation, 10832|w| will point to offset $w_k$; |m| and |n| will record the current 10833lattice positions. The values of |move_ptr| after the initial and before 10834the final offset adjustments are stored in |smooth_bot| and |smooth_top|, 10835respectively. 10836 10837@<Other local variables for |fill_envelope|@>= 10838@!m,@!n:integer; {current lattice position} 10839@!mm0,@!mm1:integer; {skewed equivalents of |m0| and |m1|} 10840@!k:integer; {current offset number} 10841@!w,@!ww:pointer; {pointers to the current offset and its neighbor} 10842@!smooth_bot,@!smooth_top:0..move_size; {boundaries of smoothing} 10843@!xx,@!yy,@!xp,@!yp,@!delx,@!dely,@!tx,@!ty:scaled; 10844 {registers for coordinate calculations} 10845 10846@ @<Make the envelope moves for the current octant...@>= 10847if odd(octant_number[octant]) then 10848 begin @<Initialize for ordinary envelope moves@>; 10849 r:=p; right_type(q):=info(h)+1; 10850 loop@+ begin if r=q then smooth_top:=move_ptr; 10851 while right_type(r)<>k do 10852 @<Insert a line segment to approach the correct offset@>; 10853 if r=p then smooth_bot:=move_ptr; 10854 if r=q then goto done; 10855 move[move_ptr]:=1; n:=move_ptr; s:=link(r);@/ 10856 make_moves(x_coord(r)+x_coord(w),right_x(r)+x_coord(w), 10857 left_x(s)+x_coord(w),x_coord(s)+x_coord(w),@| 10858 y_coord(r)+y_coord(w)+half_unit,right_y(r)+y_coord(w)+half_unit, 10859 left_y(s)+y_coord(w)+half_unit,y_coord(s)+y_coord(w)+half_unit,@| 10860 xy_corr[octant],y_corr[octant]);@/ 10861 @<Transfer moves from the |move| array to |env_move|@>; 10862 r:=s; 10863 end; 10864done: @<Insert the new envelope moves in the pixel data@>; 10865 end 10866else dual_moves(h,p,q); 10867right_type(q):=endpoint 10868 10869@ @<Initialize for ordinary envelope moves@>= 10870k:=0; w:=link(h); ww:=knil(w); 10871mm0:=floor_unscaled(x_coord(p)+x_coord(w)-xy_corr[octant]); 10872mm1:=floor_unscaled(x_coord(q)+x_coord(ww)-xy_corr[octant]); 10873for n:=0 to n1-n0 do env_move[n]:=mm0; 10874env_move[n1-n0]:=mm1; move_ptr:=0; m:=mm0 10875 10876@ At this point |n| holds the value of |move_ptr| that was current 10877when |make_moves| began to record its moves. 10878 10879@<Transfer moves from the |move| array to |env_move|@>= 10880repeat m:=m+move[n]-1; 10881if m>env_move[n] then env_move[n]:=m; 10882incr(n); 10883until n>move_ptr 10884 10885@ Retrograde lines (when |k| decreases) do not need to be recorded in 10886|env_move| because their edges are not the furthest right in any row. 10887 10888@<Insert a line segment to approach the correct offset@>= 10889begin xx:=x_coord(r)+x_coord(w); yy:=y_coord(r)+y_coord(w)+half_unit; 10890@!stat if internal[tracing_edges]>unity then 10891 begin print_nl("@@ transition line "); print_int(k); print(", from "); 10892@:]]]\AT!_trans_}{\.{\AT! transition line...}@> 10893@.transition line...@> 10894 print_two_true(xx,yy-half_unit); 10895 end;@+tats@;@/ 10896if right_type(r)>k then 10897 begin incr(k); w:=link(w); 10898 xp:=x_coord(r)+x_coord(w); yp:=y_coord(r)+y_coord(w)+half_unit; 10899 if yp<>yy then 10900 @<Record a line segment from |(xx,yy)| to |(xp,yp)| in |env_move|@>; 10901 end 10902else begin decr(k); w:=knil(w); 10903 xp:=x_coord(r)+x_coord(w); yp:=y_coord(r)+y_coord(w)+half_unit; 10904 end; 10905stat if internal[tracing_edges]>unity then 10906 begin print(" to "); 10907 print_two_true(xp,yp-half_unit); 10908 print_nl(""); 10909 end;@+tats@;@/ 10910m:=floor_unscaled(xp-xy_corr[octant]); 10911move_ptr:=floor_unscaled(yp-y_corr[octant])-n0; 10912if m>env_move[move_ptr] then env_move[move_ptr]:=m; 10913end 10914 10915@ In this step we have |xp>=xx| and |yp>=yy|. 10916 10917@<Record a line segment from |(xx,yy)| to |(xp,yp)| in |env_move|@>= 10918begin ty:=floor_scaled(yy-y_corr[octant]); dely:=yp-yy; yy:=yy-ty; 10919ty:=yp-y_corr[octant]-ty; 10920if ty>=unity then 10921 begin delx:=xp-xx; yy:=unity-yy; 10922 loop@+ begin tx:=take_fraction(delx,make_fraction(yy,dely)); 10923 if ab_vs_cd(tx,dely,delx,yy)+xy_corr[octant]>0 then decr(tx); 10924 m:=floor_unscaled(xx+tx); 10925 if m>env_move[move_ptr] then env_move[move_ptr]:=m; 10926 ty:=ty-unity; 10927 if ty<unity then goto done1; 10928 yy:=yy+unity; incr(move_ptr); 10929 end; 10930 done1:end; 10931end 10932 10933@ @<Insert the new envelope moves in the pixel data@>= 10934debug if (m<>mm1)or(move_ptr<>n1-n0) then confusion("1");@+gubed@;@/ 10935@:this can't happen /}{\quad 1@> 10936move[0]:=d0+env_move[0]-mm0; 10937for n:=1 to move_ptr do 10938 move[n]:=env_move[n]-env_move[n-1]+1; 10939move[move_ptr]:=move[move_ptr]-d1; 10940if internal[smoothing]>0 then smooth_moves(smooth_bot,smooth_top); 10941move_to_edges(m0,n0,m1,n1); 10942if right_transition(q)=axis then 10943 begin w:=link(h); skew_line_edges(q,knil(w),w); 10944 end 10945 10946@ We've done it all in the odd-octant case; the only thing remaining 10947is to repeat the same ideas, upside down and/or backwards. 10948 10949The following code has been split off as a subprocedure of |fill_envelope|, 10950because some \PASCAL\ compilers cannot handle procedures as large as 10951|fill_envelope| would otherwise be. 10952 10953@<Declare the procedure called |dual_moves|@>= 10954procedure dual_moves(@!h,@!p,@!q:pointer); 10955label done,done1; 10956var @!r,@!s:pointer; {for list traversal} 10957@<Other local variables for |fill_envelope|@>@; 10958begin @<Initialize for dual envelope moves@>; 10959r:=p; {recall that |right_type(q)=endpoint=0| now} 10960loop@+ begin if r=q then smooth_top:=move_ptr; 10961 while right_type(r)<>k do 10962 @<Insert a line segment dually to approach the correct offset@>; 10963 if r=p then smooth_bot:=move_ptr; 10964 if r=q then goto done; 10965 move[move_ptr]:=1; n:=move_ptr; s:=link(r);@/ 10966 make_moves(x_coord(r)+x_coord(w),right_x(r)+x_coord(w), 10967 left_x(s)+x_coord(w),x_coord(s)+x_coord(w),@| 10968 y_coord(r)+y_coord(w)+half_unit,right_y(r)+y_coord(w)+half_unit, 10969 left_y(s)+y_coord(w)+half_unit,y_coord(s)+y_coord(w)+half_unit,@| 10970 xy_corr[octant],y_corr[octant]); 10971 @<Transfer moves dually from the |move| array to |env_move|@>; 10972 r:=s; 10973 end; 10974done:@<Insert the new envelope moves dually in the pixel data@>; 10975end; 10976 10977@ In the dual case the normal situation is to arrive with a |diagonal| 10978transition and to leave at the |axis|. The leftmost edge in each row 10979is relevant instead of the rightmost one. 10980 10981@<Initialize for dual envelope moves@>= 10982k:=info(h)+1; ww:=link(h); w:=knil(ww);@/ 10983mm0:=floor_unscaled(x_coord(p)+x_coord(w)-xy_corr[octant]); 10984mm1:=floor_unscaled(x_coord(q)+x_coord(ww)-xy_corr[octant]); 10985for n:=1 to n1-n0+1 do env_move[n]:=mm1; 10986env_move[0]:=mm0; move_ptr:=0; m:=mm0 10987 10988@ @<Transfer moves dually from the |move| array to |env_move|@>= 10989repeat if m<env_move[n] then env_move[n]:=m; 10990m:=m+move[n]-1; 10991incr(n); 10992until n>move_ptr 10993 10994@ Dual retrograde lines occur when |k| increases; the edges of such lines 10995are not the furthest left in any row. 10996 10997@<Insert a line segment dually to approach the correct offset@>= 10998begin xx:=x_coord(r)+x_coord(w); yy:=y_coord(r)+y_coord(w)+half_unit; 10999@!stat if internal[tracing_edges]>unity then 11000 begin print_nl("@@ transition line "); print_int(k); print(", from "); 11001@:]]]\AT!_trans_}{\.{\AT! transition line...}@> 11002@.transition line...@> 11003 print_two_true(xx,yy-half_unit); 11004 end;@+tats@;@/ 11005if right_type(r)<k then 11006 begin decr(k); w:=knil(w); 11007 xp:=x_coord(r)+x_coord(w); yp:=y_coord(r)+y_coord(w)+half_unit; 11008 if yp<>yy then 11009 @<Record a line segment from |(xx,yy)| to |(xp,yp)| dually in |env_move|@>; 11010 end 11011else begin incr(k); w:=link(w); 11012 xp:=x_coord(r)+x_coord(w); yp:=y_coord(r)+y_coord(w)+half_unit; 11013 end; 11014stat if internal[tracing_edges]>unity then 11015 begin print(" to "); 11016 print_two_true(xp,yp-half_unit); 11017 print_nl(""); 11018 end;@+tats@;@/ 11019m:=floor_unscaled(xp-xy_corr[octant]); 11020move_ptr:=floor_unscaled(yp-y_corr[octant])-n0; 11021if m<env_move[move_ptr] then env_move[move_ptr]:=m; 11022end 11023 11024@ Again, |xp>=xx| and |yp>=yy|; but this time we are interested in the {\sl 11025smallest\/} |m| that belongs to a given |move_ptr| position, instead of 11026the largest~|m|. 11027 11028@<Record a line segment from |(xx,yy)| to |(xp,yp)| dually in |env_move|@>= 11029begin ty:=floor_scaled(yy-y_corr[octant]); dely:=yp-yy; yy:=yy-ty; 11030ty:=yp-y_corr[octant]-ty; 11031if ty>=unity then 11032 begin delx:=xp-xx; yy:=unity-yy; 11033 loop@+ begin if m<env_move[move_ptr] then env_move[move_ptr]:=m; 11034 tx:=take_fraction(delx,make_fraction(yy,dely)); 11035 if ab_vs_cd(tx,dely,delx,yy)+xy_corr[octant]>0 then decr(tx); 11036 m:=floor_unscaled(xx+tx); 11037 ty:=ty-unity; incr(move_ptr); 11038 if ty<unity then goto done1; 11039 yy:=yy+unity; 11040 end; 11041done1: if m<env_move[move_ptr] then env_move[move_ptr]:=m; 11042 end; 11043end 11044 11045@ Since |env_move| contains minimum values instead of maximum values, the 11046finishing-up process is slightly different in the dual case. 11047 11048@<Insert the new envelope moves dually in the pixel data@>= 11049debug if (m<>mm1)or(move_ptr<>n1-n0) then confusion("2");@+gubed@;@/ 11050@:this can't happen /}{\quad 2@> 11051move[0]:=d0+env_move[1]-mm0; 11052for n:=1 to move_ptr do 11053 move[n]:=env_move[n+1]-env_move[n]+1; 11054move[move_ptr]:=move[move_ptr]-d1; 11055if internal[smoothing]>0 then smooth_moves(smooth_bot,smooth_top); 11056move_to_edges(m0,n0,m1,n1); 11057if right_transition(q)=diagonal then 11058 begin w:=link(h); skew_line_edges(q,w,knil(w)); 11059 end 11060 11061@* \[25] Elliptical pens. 11062To get the envelope of a cyclic path with respect to an ellipse, \MF\ 11063calculates the envelope with respect to a polygonal approximation to 11064the ellipse, using an approach due to John Hobby (Ph.D. thesis, 11065Stanford University, 1985). 11066@^Hobby, John Douglas@> 11067This has two important advantages over trying to obtain the ``exact'' 11068envelope: 11069 11070\yskip\textindent{1)}It gives better results, because the polygon has been 11071designed to counteract problems that arise from digitization; the 11072polygon includes sub-pixel corrections to an exact ellipse that make 11073the results essentially independent of where the path falls on the raster. 11074For example, the exact envelope with respect to a pen of diameter~1 11075blackens a pixel if and only if the path intersects a circle of diameter~1 11076inscribed in that pixel; the resulting pattern has ``blots'' when the path 11077is travelling diagonally in unfortunate raster positions. A much better 11078result is obtained when pixels are blackened only when the path intersects 11079an inscribed {\sl diamond\/} of diameter~1. Such a diamond is precisely 11080the polygon that \MF\ uses in the special case of a circle whose diameter is~1. 11081 11082\yskip\textindent{2)}Polygonal envelopes of cubic splines are cubic 11083splines, hence it isn't necessary to introduce completely different 11084routines. By contrast, exact envelopes of cubic splines with respect 11085to circles are complicated curves, more difficult to plot than cubics. 11086 11087@ Hobby's construction involves some interesting number theory. 11088If $u$ and~$v$ are relatively prime integers, we divide the 11089set of integer points $(m,n)$ into equivalence classes by saying 11090that $(m,n)$ belongs to class $um+vn$. Then any two integer points 11091that lie on a line of slope $-u/v$ belong to the same class, because 11092such points have the form $(m+tv,n-tu)$. Neighboring lines of slope $-u/v$ 11093that go through integer points are separated by distance $1/\psqrt{u^2+v^2}$ 11094from each other, and these lines are perpendicular to lines of slope~$v/u$. 11095If we start at the origin and travel a distance $k/\psqrt{u^2+v^2}$ in 11096direction $(u,v)$, we reach the line of slope~$-u/v$ whose points 11097belong to class~$k$. 11098 11099For example, let $u=2$ and $v=3$. Then the points $(0,0)$, $(3,-2)$, 11100$\ldots$ belong to class~0; the points $(-1,1)$, $(2,-1)$, $\ldots$ belong 11101to class~1; and the distance between these two lines is $1/\sqrt{13}$. 11102The point $(2,3)$ itself belongs to class~13, hence its distance from 11103the origin is $13/\sqrt{13}=\sqrt{13}$ (which we already knew). 11104 11105Suppose we wish to plot envelopes with respect to polygons with 11106integer vertices. Then the best polygon for curves that travel in 11107direction $(v,-u)$ will contain the points of class~$k$ such that 11108$k/\psqrt{u^2+v^2}$ is as close as possible to~$d$, where $d$ is the 11109maximum distance of the given ellipse from the line $ux+vy=0$. 11110 11111The |fillin| correction assumes that a diagonal line has an 11112apparent thickness $$2f\cdot\min(\vert u\vert,\vert v\vert)/\psqrt{u^2+v^2}$$ 11113greater than would be obtained with truly square pixels. (If a 11114white pixel at an exterior corner is assumed to have apparent 11115darkness $f_1$ and a black pixel at an interior corner is assumed 11116to have apparent darkness $1-f_2$, then $f=f_1-f_2$ is the |fillin| 11117parameter.) Under this assumption we want to choose $k$ so that 11118$\bigl(k+2f\cdot\min(\vert u\vert,\vert v\vert)\bigr)\big/\psqrt{u^2+v^2}$ 11119is as close as possible to $d$. 11120 11121Integer coordinates for the vertices work nicely because the thickness of 11122the envelope at any given slope is independent of the position of the 11123path with respect to the raster. It turns out, in fact, that the same 11124property holds for polygons whose vertices have coordinates that are 11125integer multiples of~$1\over2$, because ellipses are symmetric about 11126the origin. It's convenient to double all dimensions and require the 11127resulting polygon to have vertices with integer coordinates. For example, 11128to get a circle of {\sl diameter}~$r$, we shall compute integer 11129coordinates for a circle of {\sl radius}~$r$. The circle of radius~$r$ 11130will want to be represented by a polygon that contains the boundary 11131points $(0,\pm r)$ and~$(\pm r,0)$; later we will divide everything 11132by~2 and get a polygon with $(0,\pm{1\over2}r)$ and $(\pm{1\over2}r,0)$ 11133on its boundary. 11134 11135@ In practice the important slopes are those having small values of 11136$u$ and~$v$; these make regular patterns in which our eyes quickly 11137spot irregularities. For example, horizontal and vertical lines 11138(when $u=0$ and $\vert v\vert=1$, or $\vert u\vert=1$ and $v=0$) 11139are the most important; diagonal lines (when $\vert u\vert=\vert v\vert=1$) 11140are next; and then come lines with slope $\pm2$ or $\pm1/2$. 11141 11142The nicest way to generate all rational directions having small 11143numerators and denominators is to generalize the Stern--Brocot tree 11144[cf.~{\sl Concrete Mathematics}, section 4.5] 11145@^Brocot, Achille@> 11146@^Stern, Moritz Abraham@> 11147to a ``Stern--Brocot wreath'' as follows: Begin with four nodes 11148arranged in a circle, containing the respective directions 11149$(u,v)=(1,0)$, $(0,1)$, $(-1,0)$, and~$(0,-1)$. Then between pairs of 11150consecutive terms $(u,v)$ and $(u',v')$ of the wreath, insert the 11151direction $(u+u',v+v')$; continue doing this until some stopping 11152criterion is fulfilled. 11153 11154It is not difficult to verify that, regardless of the stopping 11155criterion, consecutive directions $(u,v)$ and $(u',v')$ of this 11156wreath will always satisfy the relation $uv'-u'v=1$. Such pairs 11157of directions have a nice property with respect to the equivalence 11158classes described above. Let $l$ be a line of equivalent integer points 11159$(m+tv,n-tu)$ with respect to~$(u,v)$, and let $l'$ be a line of 11160equivalent integer points $(m'+tv',n'-tu')$ with respect to~$(u',v')$. 11161Then $l$ and~$l'$ intersect in an integer point $(m'',n'')$, because 11162the determinant of the linear equations for intersection is $uv'-u'v=1$. 11163Notice that the class number of $(m'',n'')$ with respect to $(u+u',v+v')$ 11164is the sum of its class numbers with respect to $(u,v)$ and~$(u',v')$. 11165Moreover, consecutive points on~$l$ and~$l'$ belong to classes that 11166differ by exactly~1 with respect to $(u+u',v+v')$. 11167 11168This leads to a nice algorithm in which we construct a polygon having 11169``correct'' class numbers for as many small-integer directions $(u,v)$ 11170as possible: Assuming that lines $l$ and~$l'$ contain points of the 11171correct class for $(u,v)$ and~$(u',v')$, respectively, we determine 11172the intersection $(m'',n'')$ and compute its class with respect to 11173$(u+u',v+v')$. If the class is too large to be the best approximation, 11174we move back the proper number of steps from $(m'',n'')$ toward smaller 11175class numbers on both $l$ and~$l'$, unless this requires moving to points 11176that are no longer in the polygon; in this way we arrive at two points that 11177determine a line~$l''$ having the appropriate class. The process continues 11178recursively, until it cannot proceed without removing the last remaining 11179point from the class for $(u,v)$ or the class for $(u',v')$. 11180 11181@ The |make_ellipse| subroutine produces a pointer to a cyclic path 11182whose vertices define a polygon suitable for envelopes. The control 11183points on this path will be ignored; in fact, the fields in knot nodes 11184that are usually reserved for control points are occupied by other 11185data that helps |make_ellipse| compute the desired polygon. 11186 11187Parameters |major_axis| and |minor_axis| define the axes of the ellipse; 11188and parameter |theta| is an angle by which the ellipse is rotated 11189counterclockwise. If |theta=0|, the ellipse has the equation 11190$(x/a)^2+(y/b)^2=1$, where |a=major_axis/2| and |b=minor_axis/2|. 11191In general, the points of the ellipse are generated in the complex plane 11192by the formula $e^{i\theta}(a\cos t+ib\sin t)$, as $t$~ranges over all 11193angles. Notice that if |major_axis=minor_axis=d|, we obtain a circle 11194of diameter~|d|, regardless of the value of |theta|. 11195 11196The method sketched above is used to produce the elliptical polygon, 11197except that the main work is done only in the halfplane obtained from 11198the three starting directions $(0,-1)$, $(1,0)$,~$(0,1)$. Since the ellipse 11199has circular symmetry, we use the fact that the last half of the polygon 11200is simply the negative of the first half. Furthermore, we need to compute only 11201one quarter of the polygon if the ellipse has axis symmetry. 11202 11203@p function make_ellipse(@!major_axis,@!minor_axis:scaled; 11204 @!theta:angle):pointer; 11205label done,done1,found; 11206var @!p,@!q,@!r,@!s:pointer; {for list manipulation} 11207@!h:pointer; {head of the constructed knot list} 11208@!alpha,@!beta,@!gamma,@!delta:integer; {special points} 11209@!c,@!d:integer; {class numbers} 11210@!u,@!v:integer; {directions} 11211@!symmetric:boolean; {should the result be symmetric about the axes?} 11212begin @<Initialize the ellipse data structure by beginning with 11213 directions $(0,-1)$, $(1,0)$, $(0,1)$@>; 11214@<Interpolate new vertices in the ellipse data structure until 11215 improvement is impossible@>; 11216if symmetric then 11217 @<Complete the half ellipse by reflecting the quarter already computed@>; 11218@<Complete the ellipse by copying the negative of the half already computed@>; 11219make_ellipse:=h; 11220end; 11221 11222@ A special data structure is used only with |make_ellipse|: The 11223|right_x|, |left_x|, |right_y|, and |left_y| fields of knot nodes 11224are renamed |right_u|, |left_v|, |right_class|, and |left_length|, 11225in order to store information that simplifies the necessary computations. 11226 11227If |p| and |q| are consecutive knots in this data structure, the 11228|x_coord| and |y_coord| fields of |p| and~|q| contain current vertices 11229of the polygon; their values are integer multiples 11230of |half_unit|. Both of these vertices belong to equivalence class 11231|right_class(p)| with respect to the direction 11232$\bigl($|right_u(p),left_v(q)|$\bigr)$. The number of points of this class 11233on the line from vertex~|p| to vertex~|q| is |1+left_length(q)|. 11234In particular, |left_length(q)=0| means that |x_coord(p)=x_coord(q)| 11235and |y_coord(p)=y_coord(q)|; such duplicate vertices will be 11236discarded during the course of the algorithm. 11237 11238The contents of |right_u(p)| and |left_v(q)| are integer multiples 11239of |half_unit|, just like the coordinate fields. Hence, for example, 11240the point $\bigl($|x_coord(p)-left_v(q),y_coord(p)+right_u(p)|$\bigr)$ 11241also belongs to class number |right_class(p)|. This point is one 11242step closer to the vertex in node~|q|; it equals that vertex 11243if and only if |left_length(q)=1|. 11244 11245The |left_type| and |right_type| fields are not used, but |link| 11246has its normal meaning. 11247 11248To start the process, we create four nodes for the three directions 11249$(0,-1)$, $(1,0)$, and $(0,1)$. The corresponding vertices are 11250$(-\alpha,-\beta)$, $(\gamma,-\beta)$, $(\gamma,\beta)$, and 11251$(\alpha,\beta)$, where $(\alpha,\beta)$ is a half-integer approximation 11252to where the ellipse rises highest above the $x$-axis, and where 11253$\gamma$ is a half-integer approximation to the maximum $x$~coordinate 11254of the ellipse. The fourth of these nodes is not actually calculated 11255if the ellipse has axis symmetry. 11256 11257@d right_u==right_x {|u| value for a pen edge} 11258@d left_v==left_x {|v| value for a pen edge} 11259@d right_class==right_y {equivalence class number of a pen edge} 11260@d left_length==left_y {length of a pen edge} 11261 11262@<Initialize the ellipse data structure...@>= 11263@<Calculate integers $\alpha$, $\beta$, $\gamma$ for the vertex 11264 coordinates@>; 11265p:=get_node(knot_node_size); q:=get_node(knot_node_size); 11266r:=get_node(knot_node_size); 11267if symmetric then s:=null@+else s:=get_node(knot_node_size); 11268h:=p; link(p):=q; link(q):=r; link(r):=s; {|s=null| or |link(s)=null|} 11269@<Revise the values of $\alpha$, $\beta$, $\gamma$, if necessary, 11270 so that degenerate lines of length zero will not be obtained@>; 11271x_coord(p):=-alpha*half_unit; 11272y_coord(p):=-beta*half_unit; 11273x_coord(q):=gamma*half_unit;@/ 11274y_coord(q):=y_coord(p); x_coord(r):=x_coord(q);@/ 11275right_u(p):=0; left_v(q):=-half_unit;@/ 11276right_u(q):=half_unit; left_v(r):=0;@/ 11277right_u(r):=0; 11278right_class(p):=beta; right_class(q):=gamma; right_class(r):=beta;@/ 11279left_length(q):=gamma+alpha; 11280if symmetric then 11281 begin y_coord(r):=0; left_length(r):=beta; 11282 end 11283else begin y_coord(r):=-y_coord(p); left_length(r):=beta+beta;@/ 11284 x_coord(s):=-x_coord(p); y_coord(s):=y_coord(r);@/ 11285 left_v(s):=half_unit; left_length(s):=gamma-alpha; 11286 end 11287 11288@ One of the important invariants of the pen data structure is that 11289the points are distinct. We may need to correct the pen specification 11290in order to avoid this. (The result of \&{pencircle} will always be at 11291least one pixel wide and one pixel tall, although \&{makepen} is 11292capable of producing smaller pens.) 11293 11294@<Revise the values of $\alpha$, $\beta$, $\gamma$, if necessary...@>= 11295if beta=0 then beta:=1; 11296if gamma=0 then gamma:=1; 11297if gamma<=abs(alpha) then 11298 if alpha>0 then alpha:=gamma-1 11299 else alpha:=1-gamma 11300 11301@ If $a$ and $b$ are the semi-major and semi-minor axes, 11302the given ellipse rises highest above the $x$-axis at the point 11303$\bigl((a^2-b^2)\sin\theta\cos\theta/\rho\bigr)+i\rho$, where 11304$\rho=\sqrt{(a\sin\theta)^2+(b\cos\theta)^2}$. It reaches 11305furthest to the right of~the $y$-axis at the point 11306$\sigma+i(a^2-b^2)\sin\theta\cos\theta/\sigma$, where 11307$\sigma=\sqrt{(a\cos\theta)^2+(b\sin\theta)^2}$. 11308 11309@<Calculate integers $\alpha$, $\beta$, $\gamma$...@>= 11310if (major_axis=minor_axis)or(theta mod ninety_deg=0) then 11311 begin symmetric:=true; alpha:=0; 11312 if odd(theta div ninety_deg) then 11313 begin beta:=major_axis; gamma:=minor_axis; 11314 n_sin:=fraction_one; n_cos:=0; {|n_sin| and |n_cos| are used later} 11315 end 11316 else begin beta:=minor_axis; gamma:=major_axis; theta:=0; 11317 end; {|n_sin| and |n_cos| aren't needed in this case} 11318 end 11319else begin symmetric:=false; 11320 n_sin_cos(theta); {set up $|n_sin|=\sin\theta$ and $|n_cos|=\cos\theta$} 11321 gamma:=take_fraction(major_axis,n_sin); 11322 delta:=take_fraction(minor_axis,n_cos); 11323 beta:=pyth_add(gamma,delta); 11324 alpha:=take_fraction(take_fraction(major_axis, 11325 make_fraction(gamma,beta)),n_cos)@| 11326 -take_fraction(take_fraction(minor_axis, 11327 make_fraction(delta,beta)),n_sin); 11328 alpha:=(alpha+half_unit) div unity; 11329 gamma:=pyth_add(take_fraction(major_axis,n_cos), 11330 take_fraction(minor_axis,n_sin)); 11331 end; 11332beta:=(beta+half_unit) div unity; 11333gamma:=(gamma+half_unit) div unity 11334 11335@ Now |p|, |q|, and |r| march through the list, always representing 11336three consecutive vertices and two consecutive slope directions. 11337When a new slope is interpolated, we back up slightly, until 11338further refinement is impossible; then we march forward again. 11339The somewhat magical operations performed in this part of the 11340algorithm are justified by the theory sketched earlier. 11341Complications arise only from the need to keep zero-length lines 11342out of the final data structure. 11343 11344@<Interpolate new vertices in the ellipse data structure...@>= 11345loop@+ begin u:=right_u(p)+right_u(q); v:=left_v(q)+left_v(r); 11346 c:=right_class(p)+right_class(q);@/ 11347 @<Compute the distance |d| from class~0 to the edge of the ellipse 11348 in direction |(u,v)|, times $\psqrt{u^2+v^2}$, 11349 rounded to the nearest integer@>; 11350 delta:=c-d; {we want to move |delta| steps back 11351 from the intersection vertex~|q|} 11352 if delta>0 then 11353 begin if delta>left_length(r) then delta:=left_length(r); 11354 if delta>=left_length(q) then 11355 @<Remove the line from |p| to |q|, 11356 and adjust vertex~|q| to introduce a new line@> 11357 else @<Insert a new line for direction |(u,v)| between |p| and~|q|@>; 11358 end 11359 else p:=q; 11360 @<Move to the next remaining triple |(p,q,r)|, removing and skipping past 11361 zero-length lines that might be present; |goto done| if all 11362 triples have been processed@>; 11363 end; 11364done: 11365 11366@ The appearance of a zero-length line means that we should advance |p| 11367past it. We must not try to straddle a missing direction, because the 11368algorithm works only on consecutive pairs of directions. 11369 11370@<Move to the next remaining triple |(p,q,r)|...@>= 11371loop@+ begin q:=link(p); 11372 if q=null then goto done; 11373 if left_length(q)=0 then 11374 begin link(p):=link(q); right_class(p):=right_class(q); 11375 right_u(p):=right_u(q); free_node(q,knot_node_size); 11376 end 11377 else begin r:=link(q); 11378 if r=null then goto done; 11379 if left_length(r)=0 then 11380 begin link(p):=r; free_node(q,knot_node_size); p:=r; 11381 end 11382 else goto found; 11383 end; 11384 end; 11385found: 11386 11387@ The `\&{div} 8' near the end of this step comes from 11388the fact that |delta| is scaled by~$2^{15}$ and $d$~by~$2^{16}$, 11389while |take_fraction| removes a scale factor of~$2^{28}$. 11390We also make sure that $d\G\max(\vert u\vert,\vert v\vert)$, so that 11391the pen will always include a circular pen of diameter~1 as a subset; 11392then it won't be possible to get disconnected path envelopes. 11393 11394@<Compute the distance |d| from class~0 to the edge of the ellipse...@>= 11395delta:=pyth_add(u,v); 11396if major_axis=minor_axis then d:=major_axis {circles are easy} 11397else begin if theta=0 then 11398 begin alpha:=u; beta:=v; 11399 end 11400 else begin alpha:=take_fraction(u,n_cos)+take_fraction(v,n_sin); 11401 beta:=take_fraction(v,n_cos)-take_fraction(u,n_sin); 11402 end; 11403 alpha:=make_fraction(alpha,delta); 11404 beta:=make_fraction(beta,delta); 11405 d:=pyth_add(take_fraction(major_axis,alpha), 11406 take_fraction(minor_axis,beta)); 11407 end; 11408alpha:=abs(u); beta:=abs(v); 11409if alpha<beta then 11410 begin alpha:=abs(v); beta:=abs(u); 11411 end; {now $\alpha=\max(\vert u\vert,\vert v\vert)$, 11412 $\beta=\min(\vert u\vert,\vert v\vert)$} 11413if internal[fillin]<>0 then 11414 d:=d-take_fraction(internal[fillin],make_fraction(beta+beta,delta)); 11415d:=take_fraction((d+4) div 8,delta); alpha:=alpha div half_unit; 11416if d<alpha then d:=alpha 11417 11418@ At this point there's a line of length |<=delta| from vertex~|p| 11419to vertex~|q|, orthogonal to direction $\bigl($|right_u(p),left_v(q)|$\bigr)$; 11420and there's a line of length |>=delta| from vertex~|q| to 11421to vertex~|r|, orthogonal to direction $\bigl($|right_u(q),left_v(r)|$\bigr)$. 11422The best line to direction $(u,v)$ should replace the line from 11423|p| to~|q|; this new line will have the same length as the old. 11424 11425@<Remove the line from |p| to |q|...@>= 11426begin delta:=left_length(q);@/ 11427right_class(p):=c-delta; right_u(p):=u; left_v(q):=v;@/ 11428x_coord(q):=x_coord(q)-delta*left_v(r); 11429y_coord(q):=y_coord(q)+delta*right_u(q);@/ 11430left_length(r):=left_length(r)-delta; 11431end 11432 11433@ Here is the main case, now that we have dealt with the exception: 11434We insert a new line of length |delta| for direction |(u,v)|, decreasing 11435each of the adjacent lines by |delta| steps. 11436 11437@<Insert a new line for direction |(u,v)| between |p| and~|q|@>= 11438begin s:=get_node(knot_node_size); link(p):=s; link(s):=q;@/ 11439x_coord(s):=x_coord(q)+delta*left_v(q); 11440y_coord(s):=y_coord(q)-delta*right_u(p);@/ 11441x_coord(q):=x_coord(q)-delta*left_v(r); 11442y_coord(q):=y_coord(q)+delta*right_u(q);@/ 11443left_v(s):=left_v(q); right_u(s):=u; left_v(q):=v;@/ 11444right_class(s):=c-delta;@/ 11445left_length(s):=left_length(q)-delta; left_length(q):=delta; 11446left_length(r):=left_length(r)-delta; 11447end 11448 11449@ Only the coordinates need to be copied, not the class numbers and other stuff. 11450At this point either |link(p)| or |link(link(p))| is |null|. 11451 11452@<Complete the half ellipse...@>= 11453begin s:=null; q:=h; 11454loop@+ begin r:=get_node(knot_node_size); link(r):=s; s:=r;@/ 11455 x_coord(s):=x_coord(q); y_coord(s):=-y_coord(q); 11456 if q=p then goto done1; 11457 q:=link(q); 11458 if y_coord(q)=0 then goto done1; 11459 end; 11460done1: if (link(p)<>null) then free_node(link(p),knot_node_size); 11461link(p):=s; beta:=-y_coord(h); 11462while y_coord(p)<>beta do p:=link(p); 11463q:=link(p); 11464end 11465 11466@ Now we use a somewhat tricky fact: The pointer |q| will be null if and 11467only if the line for the final direction $(0,1)$ has been removed. If 11468that line still survives, it should be combined with a possibly 11469surviving line in the initial direction $(0,-1)$. 11470 11471@<Complete the ellipse by copying...@>= 11472if q<>null then 11473 begin if right_u(h)=0 then 11474 begin p:=h; h:=link(h); free_node(p,knot_node_size);@/ 11475 x_coord(q):=-x_coord(h); 11476 end; 11477 p:=q; 11478 end 11479else q:=p; 11480r:=link(h); {now |p=q|, |x_coord(p)=-x_coord(h)|, |y_coord(p)=-y_coord(h)|} 11481repeat s:=get_node(knot_node_size); link(p):=s; p:=s;@/ 11482x_coord(p):=-x_coord(r); y_coord(p):=-y_coord(r); r:=link(r); 11483until r=q; 11484link(p):=h 11485 11486@* \[26] Direction and intersection times. 11487A path of length $n$ is defined parametrically by functions $x(t)$ and 11488$y(t)$, for |0<=t<=n|; we can regard $t$ as the ``time'' at which the path 11489reaches the point $\bigl(x(t),y(t)\bigr)$. In this section of the program 11490we shall consider operations that determine special times associated with 11491given paths: the first time that a path travels in a given direction, and 11492a pair of times at which two paths cross each other. 11493 11494@ Let's start with the easier task. The function |find_direction_time| is 11495given a direction |(x,y)| and a path starting at~|h|. If the path never 11496travels in direction |(x,y)|, the direction time will be~|-1|; otherwise 11497it will be nonnegative. 11498 11499Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given 11500direction is undefined, the direction time will be~0. If $\bigl(x'(t), 11501y'(t)\bigr)=(0,0)$, so that the path direction is undefined, it will be 11502assumed to match any given direction at time~|t|. 11503 11504The routine solves this problem in nondegenerate cases by rotating the path 11505and the given direction so that |(x,y)=(1,0)|; i.e., the main task will be 11506to find when a given path first travels ``due east.'' 11507 11508@p function find_direction_time(@!x,@!y:scaled;@!h:pointer):scaled; 11509label exit,found,not_found,done; 11510var @!max:scaled; {$\max\bigl(\vert x\vert,\vert y\vert\bigr)$} 11511@!p,@!q:pointer; {for list traversal} 11512@!n:scaled; {the direction time at knot |p|} 11513@!tt:scaled; {the direction time within a cubic} 11514@<Other local variables for |find_direction_time|@>@; 11515begin @<Normalize the given direction for better accuracy; 11516 but |return| with zero result if it's zero@>; 11517n:=0; p:=h; 11518loop@+ begin if right_type(p)=endpoint then goto not_found; 11519 q:=link(p); 11520 @<Rotate the cubic between |p| and |q|; then 11521 |goto found| if the rotated cubic travels due east at some time |tt|; 11522 but |goto not_found| if an entire cyclic path has been traversed@>; 11523 p:=q; n:=n+unity; 11524 end; 11525not_found: find_direction_time:=-unity; return; 11526found: find_direction_time:=n+tt; 11527exit:end; 11528 11529@ @<Normalize the given direction for better accuracy...@>= 11530if abs(x)<abs(y) then 11531 begin x:=make_fraction(x,abs(y)); 11532 if y>0 then y:=fraction_one@+else y:=-fraction_one; 11533 end 11534else if x=0 then 11535 begin find_direction_time:=0; return; 11536 end 11537else begin y:=make_fraction(y,abs(x)); 11538 if x>0 then x:=fraction_one@+else x:=-fraction_one; 11539 end 11540 11541@ Since we're interested in the tangent directions, we work with the 11542derivative $${1\over3}B'(x_0,x_1,x_2,x_3;t)= 11543B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of 11544$B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scaled up 11545in order to achieve better accuracy. 11546 11547The given path may turn abruptly at a knot, and it might pass the critical 11548tangent direction at such a time. Therefore we remember the direction |phi| 11549in which the previous rotated cubic was traveling. (The value of |phi| will be 11550undefined on the first cubic, i.e., when |n=0|.) 11551 11552@<Rotate the cubic between |p| and |q|; then...@>= 11553tt:=0; 11554@<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control 11555 points of the rotated derivatives@>; 11556if y1=0 then if x1>=0 then goto found; 11557if n>0 then 11558 begin @<Exit to |found| if an eastward direction occurs at knot |p|@>; 11559 if p=h then goto not_found; 11560 end; 11561if (x3<>0)or(y3<>0) then phi:=n_arg(x3,y3); 11562@<Exit to |found| if the curve whose derivatives are specified by 11563 |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|@> 11564 11565@ @<Other local variables for |find_direction_time|@>= 11566@!x1,@!x2,@!x3,@!y1,@!y2,@!y3:scaled; {multiples of rotated derivatives} 11567@!theta,@!phi:angle; {angles of exit and entry at a knot} 11568@!t:fraction; {temp storage} 11569 11570@ @<Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples...@>= 11571x1:=right_x(p)-x_coord(p); x2:=left_x(q)-right_x(p); 11572x3:=x_coord(q)-left_x(q);@/ 11573y1:=right_y(p)-y_coord(p); y2:=left_y(q)-right_y(p); 11574y3:=y_coord(q)-left_y(q);@/ 11575max:=abs(x1); 11576if abs(x2)>max then max:=abs(x2); 11577if abs(x3)>max then max:=abs(x3); 11578if abs(y1)>max then max:=abs(y1); 11579if abs(y2)>max then max:=abs(y2); 11580if abs(y3)>max then max:=abs(y3); 11581if max=0 then goto found; 11582while max<fraction_half do 11583 begin double(max); double(x1); double(x2); double(x3); 11584 double(y1); double(y2); double(y3); 11585 end; 11586t:=x1; x1:=take_fraction(x1,x)+take_fraction(y1,y); 11587y1:=take_fraction(y1,x)-take_fraction(t,y);@/ 11588t:=x2; x2:=take_fraction(x2,x)+take_fraction(y2,y); 11589y2:=take_fraction(y2,x)-take_fraction(t,y);@/ 11590t:=x3; x3:=take_fraction(x3,x)+take_fraction(y3,y); 11591y3:=take_fraction(y3,x)-take_fraction(t,y) 11592 11593@ @<Exit to |found| if an eastward direction occurs at knot |p|@>= 11594theta:=n_arg(x1,y1); 11595if theta>=0 then if phi<=0 then if phi>=theta-one_eighty_deg then goto found; 11596if theta<=0 then if phi>=0 then if phi<=theta+one_eighty_deg then goto found 11597 11598@ In this step we want to use the |crossing_point| routine to find the 11599roots of the quadratic equation $B(y_1,y_2,y_3;t)=0$. 11600Several complications arise: If the quadratic equation has a double root, 11601the curve never crosses zero, and |crossing_point| will find nothing; 11602this case occurs iff $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic 11603equation has simple roots, or only one root, we may have to negate it 11604so that $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root. 11605And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is 11606identically zero. 11607 11608@ @<Exit to |found| if the curve whose derivatives are specified by...@>= 11609if x1<0 then if x2<0 then if x3<0 then goto done; 11610if ab_vs_cd(y1,y3,y2,y2)=0 then 11611 @<Handle the test for eastward directions when $y_1y_3=y_2^2$; 11612 either |goto found| or |goto done|@>; 11613if y1<=0 then 11614 if y1<0 then 11615 begin y1:=-y1; y2:=-y2; y3:=-y3; 11616 end 11617 else if y2>0 then 11618 begin y2:=-y2; y3:=-y3; 11619 end; 11620@<Check the places where $B(y_1,y_2,y_3;t)=0$ to see if 11621 $B(x_1,x_2,x_3;t)\ge0$@>; 11622done: 11623 11624@ The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most 11625two roots, because we know that it isn't identically zero. 11626 11627It must be admitted that the |crossing_point| routine is not perfectly accurate; 11628rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or to 11629miss the roots when $y_1y_3<y_2^2$. The rotation process is itself 11630subject to rounding errors. Yet this code optimistically tries to 11631do the right thing. 11632 11633@d we_found_it==begin tt:=(t+@'4000) div @'10000; goto found; 11634 end 11635 11636@<Check the places where $B(y_1,y_2,y_3;t)=0$...@>= 11637t:=crossing_point(y1,y2,y3); 11638if t>fraction_one then goto done; 11639y2:=t_of_the_way(y2)(y3); 11640x1:=t_of_the_way(x1)(x2); 11641x2:=t_of_the_way(x2)(x3); 11642x1:=t_of_the_way(x1)(x2); 11643if x1>=0 then we_found_it; 11644if y2>0 then y2:=0; 11645tt:=t; t:=crossing_point(0,-y2,-y3); 11646if t>fraction_one then goto done; 11647x1:=t_of_the_way(x1)(x2); 11648x2:=t_of_the_way(x2)(x3); 11649if t_of_the_way(x1)(x2)>=0 then 11650 begin t:=t_of_the_way(tt)(fraction_one); we_found_it; 11651 end 11652 11653@ @<Handle the test for eastward directions when $y_1y_3=y_2^2$; 11654 either |goto found| or |goto done|@>= 11655begin if ab_vs_cd(y1,y2,0,0)<0 then 11656 begin t:=make_fraction(y1,y1-y2); 11657 x1:=t_of_the_way(x1)(x2); 11658 x2:=t_of_the_way(x2)(x3); 11659 if t_of_the_way(x1)(x2)>=0 then we_found_it; 11660 end 11661else if y3=0 then 11662 if y1=0 then 11663 @<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|@> 11664 else if x3>=0 then 11665 begin tt:=unity; goto found; 11666 end; 11667goto done; 11668end 11669 11670@ At this point we know that the derivative of |y(t)| is identically zero, 11671and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of 11672traveling east. 11673 11674@<Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0|...@>= 11675begin t:=crossing_point(-x1,-x2,-x3); 11676if t<=fraction_one then we_found_it; 11677if ab_vs_cd(x1,x3,x2,x2)<=0 then 11678 begin t:=make_fraction(x1,x1-x2); we_found_it; 11679 end; 11680end 11681 11682@ The intersection of two cubics can be found by an interesting variant 11683of the general bisection scheme described in the introduction to |make_moves|.\ 11684Given $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)$, 11685we wish to find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$, 11686if an intersection exists. First we find the smallest rectangle that 11687encloses the points $\{w_0,w_1,w_2,w_3\}$ and check that it overlaps 11688the smallest rectangle that encloses 11689$\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect. 11690But if the rectangles do overlap, we bisect the intervals, getting 11691new cubics $w'$ and~$w''$, $z'$~and~$z''$; the intersection routine first 11692tries for an intersection between $w'$ and~$z'$, then (if unsuccessful) 11693between $w'$ and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$, 11694finally (if thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful 11695levels of bisection we will have determined the intersection times $t_1$ 11696and~$t_2$ to $l$~bits of accuracy. 11697 11698\def\submin{_{\rm min}} \def\submax{_{\rm max}} 11699As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$ 11700and $Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$ 11701themselves. We also need one other quantity, $\Delta=2^l(w_0-z_0)$, 11702to determine when the enclosing rectangles overlap. Here's why: 11703The $x$~coordinates of~$w(t)$ are between $u\submin$ and $u\submax$, 11704and the $x$~coordinates of~$z(t)$ are between $x\submin$ and $x\submax$, 11705if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and $u\submin= 11706\min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates 11707overlap if and only if $u\submin\L x\submax$ and 11708$x\submin\L u\submax$. Letting 11709$$U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\; 11710 U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3),$$ 11711we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap 11712reduces to 11713$$X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin.$$ 11714Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly, 11715the quantity $2^l(v_0-y_0)$ accounts for the $y$~coordinates. The 11716coordinates of $\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases, 11717because of the overlap condition; i.e., we know that $X\submin$, 11718$X\submax$, and their relatives are bounded, hence $X\submax- 11719U\submin$ and $X\submin-U\submax$ are bounded. 11720 11721@ Incidentally, if the given cubics intersect more than once, the process 11722just sketched will not necessarily find the lexicographically smallest pair 11723$(t_1,t_2)$. The solution actually obtained will be smallest in ``shuffled 11724order''; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and 11725$t_2=(.b_1b_2\ldots b_{16})_2$, then we will minimize 11726$a_1b_1a_2b_2\ldots a_{16}b_{16}$, not 11727$a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$. 11728Shuffled order agrees with lexicographic order if all pairs of solutions 11729$(t_1,t_2)$ and $(t_1',t_2')$ have the property that $t_1<t_1'$ iff 11730$t_2<t_2'$; but in general, lexicographic order can be quite different, 11731and the bisection algorithm would be substantially less efficient if it were 11732constrained by lexicographic order. 11733 11734For example, suppose that an overlap has been found for $l=3$ and 11735$(t_1,t_2)= (.101,.011)$ in binary, but that no overlap is produced by 11736either of the alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4. 11737Then there is probably an intersection in one of the subintervals 11738$(.1011,.011x)$; but lexicographic order would require us to explore 11739$(.1010,.1xxx)$ and $(.1011,.00xx)$ and $(.1011,.010x)$ first. We wouldn't 11740want to store all of the subdivision data for the second path, so the 11741subdivisions would have to be regenerated many times. Such inefficiencies 11742would be associated with every `1' in the binary representation of~$t_1$. 11743 11744@ The subdivision process introduces rounding errors, hence we need to 11745make a more liberal test for overlap. It is not hard to show that the 11746computed values of $U_i$ differ from the truth by at most~$l$, on 11747level~$l$, hence $U\submin$ and $U\submax$ will be at most $3l$ in error. 11748If $\beta$ is an upper bound on the absolute error in the computed 11749components of $\Delta=(|delx|,|dely|)$ on level~$l$, we will replace 11750the test `$X\submin-U\submax\L|delx|$' by the more liberal test 11751`$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$. 11752 11753More accuracy is obtained if we try the algorithm first with |tol=0|; 11754the more liberal tolerance is used only if an exact approach fails. 11755It is convenient to do this double-take by letting `3' in the preceding 11756paragraph be a parameter, which is first 0, then 3. 11757 11758@<Glob...@>= 11759@!tol_step:0..6; {either 0 or 3, usually} 11760 11761@ We shall use an explicit stack to implement the recursive bisection 11762method described above. In fact, the |bisect_stack| array is available for 11763this purpose. It will contain numerous 5-word packets like 11764$(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets comprising 11765the 5-word packets for $U$, $V$, $X$, and~$Y$. 11766 11767The following macros define the allocation of stack positions to 11768the quantities needed for bisection-intersection. 11769 11770@d stack_1(#)==bisect_stack[#] {$U_1$, $V_1$, $X_1$, or $Y_1$} 11771@d stack_2(#)==bisect_stack[#+1] {$U_2$, $V_2$, $X_2$, or $Y_2$} 11772@d stack_3(#)==bisect_stack[#+2] {$U_3$, $V_3$, $X_3$, or $Y_3$} 11773@d stack_min(#)==bisect_stack[#+3] 11774 {$U\submin$, $V\submin$, $X\submin$, or $Y\submin$} 11775@d stack_max(#)==bisect_stack[#+4] 11776 {$U\submax$, $V\submax$, $X\submax$, or $Y\submax$} 11777@d int_packets=20 {number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$} 11778@# 11779@d u_packet(#)==#-5 11780@d v_packet(#)==#-10 11781@d x_packet(#)==#-15 11782@d y_packet(#)==#-20 11783@d l_packets==bisect_ptr-int_packets 11784@d r_packets==bisect_ptr 11785@d ul_packet==u_packet(l_packets) {base of $U'_k$ variables} 11786@d vl_packet==v_packet(l_packets) {base of $V'_k$ variables} 11787@d xl_packet==x_packet(l_packets) {base of $X'_k$ variables} 11788@d yl_packet==y_packet(l_packets) {base of $Y'_k$ variables} 11789@d ur_packet==u_packet(r_packets) {base of $U''_k$ variables} 11790@d vr_packet==v_packet(r_packets) {base of $V''_k$ variables} 11791@d xr_packet==x_packet(r_packets) {base of $X''_k$ variables} 11792@d yr_packet==y_packet(r_packets) {base of $Y''_k$ variables} 11793@# 11794@d u1l==stack_1(ul_packet) {$U'_1$} 11795@d u2l==stack_2(ul_packet) {$U'_2$} 11796@d u3l==stack_3(ul_packet) {$U'_3$} 11797@d v1l==stack_1(vl_packet) {$V'_1$} 11798@d v2l==stack_2(vl_packet) {$V'_2$} 11799@d v3l==stack_3(vl_packet) {$V'_3$} 11800@d x1l==stack_1(xl_packet) {$X'_1$} 11801@d x2l==stack_2(xl_packet) {$X'_2$} 11802@d x3l==stack_3(xl_packet) {$X'_3$} 11803@d y1l==stack_1(yl_packet) {$Y'_1$} 11804@d y2l==stack_2(yl_packet) {$Y'_2$} 11805@d y3l==stack_3(yl_packet) {$Y'_3$} 11806@d u1r==stack_1(ur_packet) {$U''_1$} 11807@d u2r==stack_2(ur_packet) {$U''_2$} 11808@d u3r==stack_3(ur_packet) {$U''_3$} 11809@d v1r==stack_1(vr_packet) {$V''_1$} 11810@d v2r==stack_2(vr_packet) {$V''_2$} 11811@d v3r==stack_3(vr_packet) {$V''_3$} 11812@d x1r==stack_1(xr_packet) {$X''_1$} 11813@d x2r==stack_2(xr_packet) {$X''_2$} 11814@d x3r==stack_3(xr_packet) {$X''_3$} 11815@d y1r==stack_1(yr_packet) {$Y''_1$} 11816@d y2r==stack_2(yr_packet) {$Y''_2$} 11817@d y3r==stack_3(yr_packet) {$Y''_3$} 11818@# 11819@d stack_dx==bisect_stack[bisect_ptr] {stacked value of |delx|} 11820@d stack_dy==bisect_stack[bisect_ptr+1] {stacked value of |dely|} 11821@d stack_tol==bisect_stack[bisect_ptr+2] {stacked value of |tol|} 11822@d stack_uv==bisect_stack[bisect_ptr+3] {stacked value of |uv|} 11823@d stack_xy==bisect_stack[bisect_ptr+4] {stacked value of |xy|} 11824@d int_increment=int_packets+int_packets+5 {number of stack words per level} 11825 11826@<Check the ``constant''...@>= 11827if int_packets+17*int_increment>bistack_size then bad:=32; 11828 11829@ Computation of the min and max is a tedious but fairly fast sequence of 11830instructions; exactly four comparisons are made in each branch. 11831 11832@d set_min_max(#)== 11833 if stack_1(#)<0 then 11834 if stack_3(#)>=0 then 11835 begin if stack_2(#)<0 then stack_min(#):=stack_1(#)+stack_2(#) 11836 else stack_min(#):=stack_1(#); 11837 stack_max(#):=stack_1(#)+stack_2(#)+stack_3(#); 11838 if stack_max(#)<0 then stack_max(#):=0; 11839 end 11840 else begin stack_min(#):=stack_1(#)+stack_2(#)+stack_3(#); 11841 if stack_min(#)>stack_1(#) then stack_min(#):=stack_1(#); 11842 stack_max(#):=stack_1(#)+stack_2(#); 11843 if stack_max(#)<0 then stack_max(#):=0; 11844 end 11845 else if stack_3(#)<=0 then 11846 begin if stack_2(#)>0 then stack_max(#):=stack_1(#)+stack_2(#) 11847 else stack_max(#):=stack_1(#); 11848 stack_min(#):=stack_1(#)+stack_2(#)+stack_3(#); 11849 if stack_min(#)>0 then stack_min(#):=0; 11850 end 11851 else begin stack_max(#):=stack_1(#)+stack_2(#)+stack_3(#); 11852 if stack_max(#)<stack_1(#) then stack_max(#):=stack_1(#); 11853 stack_min(#):=stack_1(#)+stack_2(#); 11854 if stack_min(#)>0 then stack_min(#):=0; 11855 end 11856 11857@ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in 11858the integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection| 11859routine uses global variables |cur_t| and |cur_tt| for this purpose; 11860after successful completion, |cur_t| and |cur_tt| will contain |unity| 11861plus the |scaled| values of $t_1$ and~$t_2$. 11862 11863The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection| 11864finds no intersection. The routine gives up and gives an approximate answer 11865if it has backtracked 11866more than 5000 times (otherwise there are cases where several minutes 11867of fruitless computation would be possible). 11868 11869@d max_patience=5000 11870 11871@<Glob...@>= 11872@!cur_t,@!cur_tt:integer; {controls and results of |cubic_intersection|} 11873@!time_to_go:integer; {this many backtracks before giving up} 11874@!max_t:integer; {maximum of $2^{l+1}$ so far achieved} 11875 11876@ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and 11877$B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,link(p))| 11878and |(pp,link(pp))|, respectively. 11879 11880@p procedure cubic_intersection(@!p,@!pp:pointer); 11881label continue, not_found, exit; 11882var @!q,@!qq:pointer; {|link(p)|, |link(pp)|} 11883begin time_to_go:=max_patience; max_t:=2; 11884@<Initialize for intersections at level zero@>; 11885loop@+ begin continue: 11886 if delx-tol<=stack_max(x_packet(xy))-stack_min(u_packet(uv)) then 11887 if delx+tol>=stack_min(x_packet(xy))-stack_max(u_packet(uv)) then 11888 if dely-tol<=stack_max(y_packet(xy))-stack_min(v_packet(uv)) then 11889 if dely+tol>=stack_min(y_packet(xy))-stack_max(v_packet(uv)) then 11890 begin if cur_t>=max_t then 11891 begin if max_t=two then {we've done 17 bisections} 11892 begin cur_t:=half(cur_t+1); cur_tt:=half(cur_tt+1); return; 11893 end; 11894 double(max_t); appr_t:=cur_t; appr_tt:=cur_tt; 11895 end; 11896 @<Subdivide for a new level of intersection@>; 11897 goto continue; 11898 end; 11899 if time_to_go>0 then decr(time_to_go) 11900 else begin while appr_t<unity do 11901 begin double(appr_t); double(appr_tt); 11902 end; 11903 cur_t:=appr_t; cur_tt:=appr_tt; return; 11904 end; 11905 @<Advance to the next pair |(cur_t,cur_tt)|@>; 11906 end; 11907exit:end; 11908 11909@ The following variables are global, although they are used only by 11910|cubic_intersection|, because it is necessary on some machines to 11911split |cubic_intersection| up into two procedures. 11912 11913@<Glob...@>= 11914@!delx,@!dely:integer; {the components of $\Delta=2^l(w_0-z_0)$} 11915@!tol:integer; {bound on the uncertainty in the overlap test} 11916@!uv,@!xy:0..bistack_size; {pointers to the current packets of interest} 11917@!three_l:integer; {|tol_step| times the bisection level} 11918@!appr_t,@!appr_tt:integer; {best approximations known to the answers} 11919 11920@ We shall assume that the coordinates are sufficiently non-extreme that 11921integer overflow will not occur. 11922@^overflow in arithmetic@> 11923 11924@<Initialize for intersections at level zero@>= 11925q:=link(p); qq:=link(pp); bisect_ptr:=int_packets;@/ 11926u1r:=right_x(p)-x_coord(p); u2r:=left_x(q)-right_x(p); 11927u3r:=x_coord(q)-left_x(q); set_min_max(ur_packet);@/ 11928v1r:=right_y(p)-y_coord(p); v2r:=left_y(q)-right_y(p); 11929v3r:=y_coord(q)-left_y(q); set_min_max(vr_packet);@/ 11930x1r:=right_x(pp)-x_coord(pp); x2r:=left_x(qq)-right_x(pp); 11931x3r:=x_coord(qq)-left_x(qq); set_min_max(xr_packet);@/ 11932y1r:=right_y(pp)-y_coord(pp); y2r:=left_y(qq)-right_y(pp); 11933y3r:=y_coord(qq)-left_y(qq); set_min_max(yr_packet);@/ 11934delx:=x_coord(p)-x_coord(pp); dely:=y_coord(p)-y_coord(pp);@/ 11935tol:=0; uv:=r_packets; xy:=r_packets; three_l:=0; cur_t:=1; cur_tt:=1 11936 11937@ @<Subdivide for a new level of intersection@>= 11938stack_dx:=delx; stack_dy:=dely; stack_tol:=tol; stack_uv:=uv; stack_xy:=xy; 11939bisect_ptr:=bisect_ptr+int_increment;@/ 11940double(cur_t); double(cur_tt);@/ 11941u1l:=stack_1(u_packet(uv)); u3r:=stack_3(u_packet(uv)); 11942u2l:=half(u1l+stack_2(u_packet(uv))); 11943u2r:=half(u3r+stack_2(u_packet(uv))); 11944u3l:=half(u2l+u2r); u1r:=u3l; 11945set_min_max(ul_packet); set_min_max(ur_packet);@/ 11946v1l:=stack_1(v_packet(uv)); v3r:=stack_3(v_packet(uv)); 11947v2l:=half(v1l+stack_2(v_packet(uv))); 11948v2r:=half(v3r+stack_2(v_packet(uv))); 11949v3l:=half(v2l+v2r); v1r:=v3l; 11950set_min_max(vl_packet); set_min_max(vr_packet);@/ 11951x1l:=stack_1(x_packet(xy)); x3r:=stack_3(x_packet(xy)); 11952x2l:=half(x1l+stack_2(x_packet(xy))); 11953x2r:=half(x3r+stack_2(x_packet(xy))); 11954x3l:=half(x2l+x2r); x1r:=x3l; 11955set_min_max(xl_packet); set_min_max(xr_packet);@/ 11956y1l:=stack_1(y_packet(xy)); y3r:=stack_3(y_packet(xy)); 11957y2l:=half(y1l+stack_2(y_packet(xy))); 11958y2r:=half(y3r+stack_2(y_packet(xy))); 11959y3l:=half(y2l+y2r); y1r:=y3l; 11960set_min_max(yl_packet); set_min_max(yr_packet);@/ 11961uv:=l_packets; xy:=l_packets; 11962double(delx); double(dely);@/ 11963tol:=tol-three_l+tol_step; double(tol); three_l:=three_l+tol_step 11964 11965@ @<Advance to the next pair |(cur_t,cur_tt)|@>= 11966not_found: if odd(cur_tt) then 11967 if odd(cur_t) then @<Descend to the previous level and |goto not_found|@> 11968 else begin incr(cur_t); 11969 delx:=delx+stack_1(u_packet(uv))+stack_2(u_packet(uv)) 11970 +stack_3(u_packet(uv)); 11971 dely:=dely+stack_1(v_packet(uv))+stack_2(v_packet(uv)) 11972 +stack_3(v_packet(uv)); 11973 uv:=uv+int_packets; {switch from |l_packets| to |r_packets|} 11974 decr(cur_tt); xy:=xy-int_packets; {switch from |r_packets| to |l_packets|} 11975 delx:=delx+stack_1(x_packet(xy))+stack_2(x_packet(xy)) 11976 +stack_3(x_packet(xy)); 11977 dely:=dely+stack_1(y_packet(xy))+stack_2(y_packet(xy)) 11978 +stack_3(y_packet(xy)); 11979 end 11980else begin incr(cur_tt); tol:=tol+three_l; 11981 delx:=delx-stack_1(x_packet(xy))-stack_2(x_packet(xy)) 11982 -stack_3(x_packet(xy)); 11983 dely:=dely-stack_1(y_packet(xy))-stack_2(y_packet(xy)) 11984 -stack_3(y_packet(xy)); 11985 xy:=xy+int_packets; {switch from |l_packets| to |r_packets|} 11986 end 11987 11988@ @<Descend to the previous level...@>= 11989begin cur_t:=half(cur_t); cur_tt:=half(cur_tt); 11990if cur_t=0 then return; 11991bisect_ptr:=bisect_ptr-int_increment; three_l:=three_l-tol_step; 11992delx:=stack_dx; dely:=stack_dy; tol:=stack_tol; uv:=stack_uv; xy:=stack_xy;@/ 11993goto not_found; 11994end 11995 11996@ The |path_intersection| procedure is much simpler. 11997It invokes |cubic_intersection| in lexicographic order until finding a 11998pair of cubics that intersect. The final intersection times are placed in 11999|cur_t| and~|cur_tt|. 12000 12001@p procedure path_intersection(@!h,@!hh:pointer); 12002label exit; 12003var @!p,@!pp:pointer; {link registers that traverse the given paths} 12004@!n,@!nn:integer; {integer parts of intersection times, minus |unity|} 12005begin @<Change one-point paths into dead cycles@>; 12006tol_step:=0; 12007repeat n:=-unity; p:=h; 12008 repeat if right_type(p)<>endpoint then 12009 begin nn:=-unity; pp:=hh; 12010 repeat if right_type(pp)<>endpoint then 12011 begin cubic_intersection(p,pp); 12012 if cur_t>0 then 12013 begin cur_t:=cur_t+n; cur_tt:=cur_tt+nn; return; 12014 end; 12015 end; 12016 nn:=nn+unity; pp:=link(pp); 12017 until pp=hh; 12018 end; 12019 n:=n+unity; p:=link(p); 12020 until p=h; 12021tol_step:=tol_step+3; 12022until tol_step>3; 12023cur_t:=-unity; cur_tt:=-unity; 12024exit:end; 12025 12026@ @<Change one-point paths...@>= 12027if right_type(h)=endpoint then 12028 begin right_x(h):=x_coord(h); left_x(h):=x_coord(h); 12029 right_y(h):=y_coord(h); left_y(h):=y_coord(h); right_type(h):=explicit; 12030 end; 12031if right_type(hh)=endpoint then 12032 begin right_x(hh):=x_coord(hh); left_x(hh):=x_coord(hh); 12033 right_y(hh):=y_coord(hh); left_y(hh):=y_coord(hh); right_type(hh):=explicit; 12034 end; 12035 12036@* \[27] Online graphic output. 12037\MF\ displays images on the user's screen by means of a few primitive 12038operations that are defined below. These operations have deliberately been 12039kept simple so that they can be implemented without great difficulty on a 12040wide variety of machines. Since \PASCAL\ has no traditional standards for 12041graphic output, some system-dependent code needs to be written in order to 12042support this aspect of \MF; but the necessary routines are usually quite 12043easy to write. 12044@^system dependencies@> 12045 12046In fact, there are exactly four such routines: 12047 12048\yskip\hang 12049|init_screen| does whatever initialization is necessary to 12050support the other operations; it is a boolean function that returns 12051|false| if graphic output cannot be supported (e.g., if the other three 12052routines have not been written, or if the user doesn't have the 12053right kind of terminal). 12054 12055\yskip\hang 12056|blank_rectangle| updates a buffer area in memory so that 12057all pixels in a specified rectangle will be set to the background color. 12058 12059\yskip\hang 12060|paint_row| assigns values to specified pixels in a row of 12061the buffer just mentioned, based on ``transition'' indices explained below. 12062 12063\yskip\hang 12064|update_screen| displays the current screen buffer; the 12065effects of |blank_rectangle| and |paint_row| commands may or may not 12066become visible until the next |update_screen| operation is performed. 12067(Thus, |update_screen| is analogous to |update_terminal|.) 12068 12069\yskip\noindent 12070The \PASCAL\ code here is a minimum version of |init_screen| and 12071|update_screen|, usable on \MF\ installations that don't 12072support screen output. If |init_screen| is changed to return |true| 12073instead of |false|, the other routines will simply log the fact 12074that they have been called; they won't really display anything. 12075The standard test routines for \MF\ use this log information to check 12076that \MF\ is working properly, but the |wlog| instructions should be 12077removed from production versions of \MF. 12078 12079@p function init_screen:boolean; 12080begin init_screen:=false; 12081end; 12082@# 12083procedure update_screen; {will be called only if |init_screen| returns |true|} 12084begin @!init wlog_ln('Calling UPDATESCREEN');@+tini {for testing only} 12085end; 12086 12087@ The user's screen is assumed to be a rectangular area, |screen_width| 12088pixels wide and |screen_depth| pixels deep. The pixel in the upper left 12089corner is said to be in column~0 of row~0; the pixel in the lower right 12090corner is said to be in column |screen_width-1| of row |screen_depth-1|. 12091Notice that row numbers increase from top to bottom, contrary to \MF's 12092other coordinates. 12093 12094Each pixel is assumed to have two states, referred to in this documentation 12095as |black| and |white|. The background color is called |white| and the 12096other color is called |black|; but any two distinct pixel values 12097can actually be used. For example, the author developed \MF\ on a 12098system for which |white| was black and |black| was bright green. 12099 12100@d white=0 {background pixels} 12101@d black=1 {visible pixels} 12102 12103@<Types...@>= 12104@!screen_row=0..screen_depth; {a row number on the screen} 12105@!screen_col=0..screen_width; {a column number on the screen} 12106@!trans_spec=array[screen_col] of screen_col; {a transition spec, see below} 12107@!pixel_color=white..black; {specifies one of the two pixel values} 12108 12109@ We'll illustrate the |blank_rectangle| and |paint_row| operations by 12110pretending to declare a screen buffer called |screen_pixel|. This code 12111is actually commented out, but it does specify the intended effects. 12112 12113@<Glob...@>= 12114@{@!screen_pixel:array[screen_row,screen_col] of pixel_color;@+@} 12115 12116@ The |blank_rectangle| routine simply whitens all pixels that lie in 12117columns |left_col| through |right_col-1|, inclusive, of rows 12118|top_row| through |bot_row-1|, inclusive, given four parameters that satisfy 12119the relations 12120$$\hbox{|0<=left_col<=right_col<=screen_width|,\quad 12121 |0<=top_row<=bot_row<=screen_depth|.}$$ 12122If |left_col=right_col| or |top_row=bot_row|, nothing happens. 12123 12124The commented-out code in the following procedure is for illustrative 12125purposes only. 12126@^system dependencies@> 12127 12128@p procedure blank_rectangle(@!left_col,@!right_col:screen_col; 12129 @!top_row,@!bot_row:screen_row); 12130var @!r:screen_row; 12131@!c:screen_col; 12132begin @{@+for r:=top_row to bot_row-1 do 12133 for c:=left_col to right_col-1 do 12134 screen_pixel[r,c]:=white;@+@}@/ 12135@!init wlog_cr; {this will be done only after |init_screen=true|} 12136wlog_ln('Calling BLANKRECTANGLE(',left_col:1,',', 12137 right_col:1,',',top_row:1,',',bot_row:1,')');@+tini 12138end; 12139 12140@ The real work of screen display is done by |paint_row|. But it's not 12141hard work, because the operation affects only 12142one of the screen rows, and it affects only a contiguous set of columns 12143in that row. There are four parameters: |r|~(the row), 12144|b|~(the initial color), 12145|a|~(the array of transition specifications), 12146and |n|~(the number of transitions). The elements of~|a| will satisfy 12147$$0\L a[0]<a[1]<\cdots<a[n]\L |screen_width|;$$ 12148the value of |r| will satisfy |0<=r<screen_depth|; and |n| will be positive. 12149 12150The general idea is to paint blocks of pixels in alternate colors; 12151the precise details are best conveyed by means of a \PASCAL\ 12152program (see the commented-out code below). 12153@^system dependencies@> 12154 12155@p procedure paint_row(@!r:screen_row;@!b:pixel_color;var @!a:trans_spec; 12156 @!n:screen_col); 12157var @!k:screen_col; {an index into |a|} 12158@!c:screen_col; {an index into |screen_pixel|} 12159begin @{ k:=0; c:=a[0]; 12160repeat incr(k); 12161 repeat screen_pixel[r,c]:=b; incr(c); 12162 until c=a[k]; 12163 b:=black-b; {$|black|\swap|white|$} 12164 until k=n;@+@}@/ 12165@!init wlog('Calling PAINTROW(',r:1,',',b:1,';'); 12166 {this is done only after |init_screen=true|} 12167for k:=0 to n do 12168 begin wlog(a[k]:1); if k<>n then wlog(','); 12169 end; 12170wlog_ln(')');@+tini 12171end; 12172 12173@ The remainder of \MF's screen routines are system-independent calls 12174on the four primitives just defined. 12175 12176First we have a global boolean variable that tells if |init_screen| 12177has been called, and another one that tells if |init_screen| has 12178given a |true| response. 12179 12180@<Glob...@>= 12181@!screen_started:boolean; {have the screen primitives been initialized?} 12182@!screen_OK:boolean; {is it legitimate to call |blank_rectangle|, 12183 |paint_row|, and |update_screen|?} 12184 12185@ @d start_screen==begin if not screen_started then 12186 begin screen_OK:=init_screen; screen_started:=true; 12187 end; 12188 end 12189 12190@<Set init...@>= 12191screen_started:=false; screen_OK:=false; 12192 12193@ \MF\ provides the user with 16 ``window'' areas on the screen, in each 12194of which it is possible to produce independent displays. 12195 12196It should be noted that \MF's windows aren't really independent 12197``clickable'' entities in the sense of multi-window graphic workstations; 12198\MF\ simply maps them into subsets of a single screen image that is 12199controlled by |init_screen|, |blank_rectangle|, |paint_row|, and 12200|update_screen| as described above. Implementations of \MF\ on a 12201multi-window workstation probably therefore make use of only two 12202windows in the other sense: one for the terminal output and another 12203for the screen with \MF's 16 areas. Henceforth we shall 12204use the term window only in \MF's sense. 12205 12206@<Types...@>= 12207@!window_number=0..15; 12208 12209@ A user doesn't have to use any of the 16 windows. But when a window is 12210``opened,'' it is allocated to a specific rectangular portion of the screen 12211and to a specific rectangle with respect to \MF's coordinates. The relevant 12212data is stored in global arrays |window_open|, |left_col|, |right_col|, 12213|top_row|, |bot_row|, |m_window|, and |n_window|. 12214 12215The |window_open| array is boolean, and its significance is obvious. The 12216|left_col|, \dots, |bot_row| arrays contain screen coordinates that 12217can be used to blank the entire window with |blank_rectangle|. And the 12218other two arrays just mentioned handle the conversion between 12219actual coordinates and screen coordinates: \MF's pixel in column~$m$ 12220of row~$n$ will appear in screen column |m_window+m| and in screen row 12221|n_window-n|, provided that these lie inside the boundaries of the window. 12222 12223Another array |window_time| holds the number of times this window has 12224been updated. 12225 12226@<Glob...@>= 12227@!window_open:array[window_number] of boolean; 12228 {has this window been opened?} 12229@!left_col:array[window_number] of screen_col; 12230 {leftmost column position on screen} 12231@!right_col:array[window_number] of screen_col; 12232 {rightmost column position, plus~1} 12233@!top_row:array[window_number] of screen_row; 12234 {topmost row position on screen} 12235@!bot_row:array[window_number] of screen_row; 12236 {bottommost row position, plus~1} 12237@!m_window:array[window_number] of integer; 12238 {offset between user and screen columns} 12239@!n_window:array[window_number] of integer; 12240 {offset between user and screen rows} 12241@!window_time:array[window_number] of integer; 12242 {it has been updated this often} 12243 12244@ @<Set init...@>= 12245for k:=0 to 15 do 12246 begin window_open[k]:=false; window_time[k]:=0; 12247 end; 12248 12249@ Opening a window isn't like opening a file, because you can open it 12250as often as you like, and you never have to close it again. The idea is 12251simply to define special points on the current screen display. 12252 12253Overlapping window specifications may cause complex effects that can 12254be understood only by scrutinizing \MF's display algorithms; thus it 12255has been left undefined in the \MF\ user manual, although the behavior 12256@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 12257is in fact predictable. 12258 12259Here is a subroutine that implements the command `\&{openwindow}~|k| 12260\&{from}~$(\\{r0},\\{c0})$ \&{to}~$(\\{r1},\\{c1})$ \&{at}~$(x,y)$'. 12261 12262@p procedure open_a_window(@!k:window_number;@!r0,@!c0,@!r1,@!c1:scaled; 12263 @!x,@!y:scaled); 12264var @!m,@!n:integer; {pixel coordinates} 12265begin @<Adjust the coordinates |(r0,c0)| and |(r1,c1)| so that 12266 they lie in the proper range@>; 12267window_open[k]:=true; incr(window_time[k]);@/ 12268left_col[k]:=c0; right_col[k]:=c1; top_row[k]:=r0; bot_row[k]:=r1;@/ 12269@<Compute the offsets between screen coordinates and actual coordinates@>; 12270start_screen; 12271if screen_OK then 12272 begin blank_rectangle(c0,c1,r0,r1); update_screen; 12273 end; 12274end; 12275 12276@ A window whose coordinates don't fit the existing screen size will be 12277truncated until they do. 12278 12279@<Adjust the coordinates |(r0,c0)| and |(r1,c1)|...@>= 12280if r0<0 then r0:=0@+else r0:=round_unscaled(r0); 12281r1:=round_unscaled(r1); 12282if r1>screen_depth then r1:=screen_depth; 12283if r1<r0 then 12284 if r0>screen_depth then r0:=r1@+else r1:=r0; 12285if c0<0 then c0:=0@+else c0:=round_unscaled(c0); 12286c1:=round_unscaled(c1); 12287if c1>screen_width then c1:=screen_width; 12288if c1<c0 then 12289 if c0>screen_width then c0:=c1@+else c1:=c0 12290 12291@ Three sets of coordinates are rampant, and they must be kept straight! 12292(i)~\MF's main coordinates refer to the edges between pixels. (ii)~\MF's 12293pixel coordinates (within edge structures) say that the pixel bounded by 12294$(m,n)$, $(m,n+1)$, $(m+1,n)$, and~$(m+1,n+1)$ is in pixel row number~$n$ 12295and pixel column number~$m$. (iii)~Screen coordinates, on the other hand, 12296have rows numbered in increasing order from top to bottom, as mentioned 12297above. 12298@^coordinates, explained@> 12299 12300The program here first computes integers $m$ and $n$ such that 12301pixel column~$m$ of pixel row~$n$ will be at the upper left corner 12302of the window. Hence pixel column |m-c0| of pixel row |n+r0| 12303will be at the upper left corner of the screen. 12304 12305@<Compute the offsets between screen coordinates and actual coordinates@>= 12306m:=round_unscaled(x); n:=round_unscaled(y)-1;@/ 12307m_window[k]:=c0-m; n_window[k]:=r0+n 12308 12309@ Now here comes \MF's most complicated operation related to window 12310display: Given the number~|k| of an open window, the pixels of positive 12311weight in |cur_edges| will be shown as |black| in the window; all other 12312pixels will be shown as |white|. 12313 12314@p procedure disp_edges(@!k:window_number); 12315label done,found; 12316var @!p,@!q:pointer; {for list manipulation} 12317@!already_there:boolean; {is a previous incarnation in the window?} 12318@!r:integer; {row number} 12319@<Other local variables for |disp_edges|@>@; 12320begin if screen_OK then 12321 if left_col[k]<right_col[k] then if top_row[k]<bot_row[k] then 12322 begin already_there:=false; 12323 if last_window(cur_edges)=k then 12324 if last_window_time(cur_edges)=window_time[k] then 12325 already_there:=true; 12326 if not already_there then 12327 blank_rectangle(left_col[k],right_col[k],top_row[k],bot_row[k]); 12328 @<Initialize for the display computations@>; 12329 p:=link(cur_edges); r:=n_window[k]-(n_min(cur_edges)-zero_field); 12330 while (p<>cur_edges)and(r>=top_row[k]) do 12331 begin if r<bot_row[k] then 12332 @<Display the pixels of edge row |p| in screen row |r|@>; 12333 p:=link(p); decr(r); 12334 end; 12335 update_screen; 12336 incr(window_time[k]); 12337 last_window(cur_edges):=k; last_window_time(cur_edges):=window_time[k]; 12338 end; 12339end; 12340 12341@ Since it takes some work to display a row, we try to avoid recomputation 12342whenever we can. 12343 12344@<Display the pixels of edge row |p| in screen row |r|@>= 12345begin if unsorted(p)>void then sort_edges(p) 12346else if unsorted(p)=void then if already_there then goto done; 12347unsorted(p):=void; {this time we'll paint, but maybe not next time} 12348@<Set up the parameters needed for |paint_row|; 12349 but |goto done| if no painting is needed after all@>; 12350paint_row(r,b,row_transition,n); 12351done: end 12352 12353@ The transition-specification parameter to |paint_row| is always the same 12354array. 12355 12356@<Glob...@>= 12357@!row_transition:trans_spec; {an array of |black|/|white| transitions} 12358 12359@ The job remaining is to go through the list |sorted(p)|, unpacking the 12360|info| fields into |m| and weight, then making |black| the pixels whose 12361accumulated weight~|w| is positive. 12362 12363@<Other local variables for |disp_edges|@>= 12364@!n:screen_col; {the highest active index in |row_transition|} 12365@!w,@!ww:integer; {old and new accumulated weights} 12366@!b:pixel_color; {status of first pixel in the row transitions} 12367@!m,@!mm:integer; {old and new screen column positions} 12368@!d:integer; {edge-and-weight without |min_halfword| compensation} 12369@!m_adjustment:integer; {conversion between edge and screen coordinates} 12370@!right_edge:integer; {largest edge-and-weight that could affect the window} 12371@!min_col:screen_col; {the smallest screen column number in the window} 12372 12373@ Some precomputed constants make the display calculations faster. 12374 12375@<Initialize for the display computations@>= 12376m_adjustment:=m_window[k]-m_offset(cur_edges);@/ 12377right_edge:=8*(right_col[k]-m_adjustment);@/ 12378min_col:=left_col[k] 12379 12380@ @<Set up the parameters needed for |paint_row|...@>= 12381n:=0; ww:=0; m:=-1; w:=0; 12382q:=sorted(p); row_transition[0]:=min_col; 12383loop@+ begin if q=sentinel then d:=right_edge 12384 else d:=ho(info(q)); 12385 mm:=(d div 8)+m_adjustment; 12386 if mm<>m then 12387 begin @<Record a possible transition in column |m|@>; 12388 m:=mm; w:=ww; 12389 end; 12390 if d>=right_edge then goto found; 12391 ww:=ww+(d mod 8)-zero_w; 12392 q:=link(q); 12393 end; 12394found:@<Wind up the |paint_row| parameter calculation by inserting the 12395 final transition; |goto done| if no painting is needed@>; 12396 12397@ Now |m| is a screen column |<right_col[k]|. 12398 12399@<Record a possible transition in column |m|@>= 12400if w<=0 then 12401 begin if ww>0 then if m>min_col then 12402 begin if n=0 then 12403 if already_there then 12404 begin b:=white; incr(n); 12405 end 12406 else b:=black 12407 else incr(n); 12408 row_transition[n]:=m; 12409 end; 12410 end 12411else if ww<=0 then if m>min_col then 12412 begin if n=0 then b:=black; 12413 incr(n); row_transition[n]:=m; 12414 end 12415 12416@ If the entire row is |white| in the window area, we can omit painting it 12417when |already_there| is false, since it has already been blanked out in 12418that case. 12419 12420When the following code is invoked, |row_transition[n]| will be 12421strictly less than |right_col[k]|. 12422 12423@<Wind up the |paint_row|...@>= 12424if already_there or(ww>0) then 12425 begin if n=0 then 12426 if ww>0 then b:=black 12427 else b:=white; 12428 incr(n); row_transition[n]:=right_col[k]; 12429 end 12430else if n=0 then goto done 12431 12432@* \[28] Dynamic linear equations. 12433\MF\ users define variables implicitly by stating equations that should be 12434satisfied; the computer is supposed to be smart enough to solve those equations. 12435And indeed, the computer tries valiantly to do so, by distinguishing five 12436different types of numeric values: 12437 12438\smallskip\hang 12439|type(p)=known| is the nice case, when |value(p)| is the |scaled| value 12440of the variable whose address is~|p|. 12441 12442\smallskip\hang 12443|type(p)=dependent| means that |value(p)| is not present, but |dep_list(p)| 12444points to a {\sl dependency list\/} that expresses the value of variable~|p| 12445as a |scaled| number plus a sum of independent variables with |fraction| 12446coefficients. 12447 12448\smallskip\hang 12449|type(p)=independent| means that |value(p)=64s+m|, where |s>0| is a ``serial 12450number'' reflecting the time this variable was first used in an equation; 12451also |0<=m<64|, and each dependent variable 12452that refers to this one is actually referring to the future value of 12453this variable times~$2^m$. (Usually |m=0|, but higher degrees of 12454scaling are sometimes needed to keep the coefficients in dependency lists 12455from getting too large. The value of~|m| will always be even.) 12456 12457\smallskip\hang 12458|type(p)=numeric_type| means that variable |p| hasn't appeared in an 12459equation before, but it has been explicitly declared to be numeric. 12460 12461\smallskip\hang 12462|type(p)=undefined| means that variable |p| hasn't appeared before. 12463 12464\smallskip\noindent 12465We have actually discussed these five types in the reverse order of their 12466history during a computation: Once |known|, a variable never again 12467becomes |dependent|; once |dependent|, it almost never again becomes 12468|independent|; once |independent|, it never again becomes |numeric_type|; 12469and once |numeric_type|, it never again becomes |undefined| (except 12470of course when the user specifically decides to scrap the old value 12471and start again). A backward step may, however, take place: Sometimes 12472a |dependent| variable becomes |independent| again, when one of the 12473independent variables it depends on is reverting to |undefined|. 12474 12475@d s_scale=64 {the serial numbers are multiplied by this factor} 12476@d new_indep(#)== {create a new independent variable} 12477 begin if serial_no>el_gordo-s_scale then 12478 overflow("independent variables",serial_no div s_scale); 12479@:METAFONT capacity exceeded independent variables}{\quad independent variables@> 12480 type(#):=independent; serial_no:=serial_no+s_scale; 12481 value(#):=serial_no; 12482 end 12483 12484@<Glob...@>= 12485@!serial_no:integer; {the most recent serial number, times |s_scale|} 12486 12487@ @<Make variable |q+s| newly independent@>=new_indep(q+s) 12488 12489@ But how are dependency lists represented? It's simple: The linear combination 12490$\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If 12491|q=dep_list(p)| points to this list, and if |k>0|, then |value(q)= 12492@t$\alpha_1$@>| (which is a |fraction|); |info(q)| points to the location 12493of $v_1$; and |link(p)| points to the dependency list 12494$\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|, 12495then |value(q)=@t$\beta$@>| (which is |scaled|) and |info(q)=null|. 12496The independent variables $v_1$, \dots,~$v_k$ have been sorted so that 12497they appear in decreasing order of their |value| fields (i.e., of 12498their serial numbers). \ (It is convenient to use decreasing order, 12499since |value(null)=0|. If the independent variables were not sorted by 12500serial number but by some other criterion, such as their location in |mem|, 12501the equation-solving mechanism would be too system-dependent, because 12502the ordering can affect the computed results.) 12503 12504The |link| field in the node that contains the constant term $\beta$ is 12505called the {\sl final link\/} of the dependency list. \MF\ maintains 12506a doubly-linked master list of all dependency lists, in terms of a permanently 12507allocated node 12508in |mem| called |dep_head|. If there are no dependencies, we have 12509|link(dep_head)=dep_head| and |prev_dep(dep_head)=dep_head|; 12510otherwise |link(dep_head)| points to the first dependent variable, say~|p|, 12511and |prev_dep(p)=dep_head|. We have |type(p)=dependent|, and |dep_list(p)| 12512points to its dependency list. If the final link of that dependency list 12513occurs in location~|q|, then |link(q)| points to the next dependent 12514variable (say~|r|); and we have |prev_dep(r)=q|, etc. 12515 12516@d dep_list(#)==link(value_loc(#)) 12517 {half of the |value| field in a |dependent| variable} 12518@d prev_dep(#)==info(value_loc(#)) 12519 {the other half; makes a doubly linked list} 12520@d dep_node_size=2 {the number of words per dependency node} 12521 12522@<Initialize table entries...@>= serial_no:=0; 12523link(dep_head):=dep_head; prev_dep(dep_head):=dep_head; 12524info(dep_head):=null; dep_list(dep_head):=null; 12525 12526@ Actually the description above contains a little white lie. There's 12527another kind of variable called |proto_dependent|, which is 12528just like a |dependent| one except that the $\alpha$ coefficients 12529in its dependency list are |scaled| instead of being fractions. 12530Proto-dependency lists are mixed with dependency lists in the 12531nodes reachable from |dep_head|. 12532 12533@ Here is a procedure that prints a dependency list in symbolic form. 12534The second parameter should be either |dependent| or |proto_dependent|, 12535to indicate the scaling of the coefficients. 12536 12537@<Declare subroutines for printing expressions@>= 12538procedure print_dependency(@!p:pointer;@!t:small_number); 12539label exit; 12540var @!v:integer; {a coefficient} 12541@!pp,@!q:pointer; {for list manipulation} 12542begin pp:=p; 12543loop@+ begin v:=abs(value(p)); q:=info(p); 12544 if q=null then {the constant term} 12545 begin if (v<>0)or(p=pp) then 12546 begin if value(p)>0 then if p<>pp then print_char("+"); 12547 print_scaled(value(p)); 12548 end; 12549 return; 12550 end; 12551 @<Print the coefficient, unless it's $\pm1.0$@>; 12552 if type(q)<>independent then confusion("dep"); 12553@:this can't happen dep}{\quad dep@> 12554 print_variable_name(q); v:=value(q) mod s_scale; 12555 while v>0 do 12556 begin print("*4"); v:=v-2; 12557 end; 12558 p:=link(p); 12559 end; 12560exit:end; 12561 12562@ @<Print the coefficient, unless it's $\pm1.0$@>= 12563if value(p)<0 then print_char("-") 12564else if p<>pp then print_char("+"); 12565if t=dependent then v:=round_fraction(v); 12566if v<>unity then print_scaled(v) 12567 12568@ The maximum absolute value of a coefficient in a given dependency list 12569is returned by the following simple function. 12570 12571@p function max_coef(@!p:pointer):fraction; 12572var @!x:fraction; {the maximum so far} 12573begin x:=0; 12574while info(p)<>null do 12575 begin if abs(value(p))>x then x:=abs(value(p)); 12576 p:=link(p); 12577 end; 12578max_coef:=x; 12579end; 12580 12581@ One of the main operations needed on dependency lists is to add a multiple 12582of one list to the other; we call this |p_plus_fq|, where |p| and~|q| point 12583to dependency lists and |f| is a fraction. 12584 12585If the coefficient of any independent variable becomes |coef_bound| or 12586more, in absolute value, this procedure changes the type of that variable 12587to `|independent_needing_fix|', and sets the global variable |fix_needed| 12588to~|true|. The value of $|coef_bound|=\mu$ is chosen so that 12589$\mu^2+\mu<8$; this means that the numbers we deal with won't 12590get too large. (Instead of the ``optimum'' $\mu=(\sqrt{33}-1)/2\approx 125912.3723$, the safer value 7/3 is taken as the threshold.) 12592 12593The changes mentioned in the preceding paragraph are actually done only if 12594the global variable |watch_coefs| is |true|. But it usually is; in fact, 12595it is |false| only when \MF\ is making a dependency list that will soon 12596be equated to zero. 12597 12598Several procedures that act on dependency lists, including |p_plus_fq|, 12599set the global variable |dep_final| to the final (constant term) node of 12600the dependency list that they produce. 12601 12602@d coef_bound==@'4525252525 {|fraction| approximation to 7/3} 12603@d independent_needing_fix=0 12604 12605@<Glob...@>= 12606@!fix_needed:boolean; {does at least one |independent| variable need scaling?} 12607@!watch_coefs:boolean; {should we scale coefficients that exceed |coef_bound|?} 12608@!dep_final:pointer; {location of the constant term and final link} 12609 12610@ @<Set init...@>= 12611fix_needed:=false; watch_coefs:=true; 12612 12613@ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be 12614set to |proto_dependent| if |p| is a proto-dependency list. In this 12615case |f| will be |scaled|, not a |fraction|. Similarly, the fifth parameter~|tt| 12616should be |proto_dependent| if |q| is a proto-dependency list. 12617 12618List |q| is unchanged by the operation; but list |p| is totally destroyed. 12619 12620The final link of the dependency list or proto-dependency list returned 12621by |p_plus_fq| is the same as the original final link of~|p|. Indeed, the 12622constant term of the result will be located in the same |mem| location 12623as the original constant term of~|p|. 12624 12625Coefficients of the result are assumed to be zero if they are less than 12626a certain threshold. This compensates for inevitable rounding errors, 12627and tends to make more variables `|known|'. The threshold is approximately 12628$10^{-5}$ in the case of normal dependency lists, $10^{-4}$ for 12629proto-dependencies. 12630 12631@d fraction_threshold=2685 {a |fraction| coefficient less than this is zeroed} 12632@d half_fraction_threshold=1342 {half of |fraction_threshold|} 12633@d scaled_threshold=8 {a |scaled| coefficient less than this is zeroed} 12634@d half_scaled_threshold=4 {half of |scaled_threshold|} 12635 12636@<Declare basic dependency-list subroutines@>= 12637function p_plus_fq(@!p:pointer;@!f:integer;@!q:pointer; 12638 @!t,@!tt:small_number):pointer; 12639label done; 12640var @!pp,@!qq:pointer; {|info(p)| and |info(q)|, respectively} 12641@!r,@!s:pointer; {for list manipulation} 12642@!threshold:integer; {defines a neighborhood of zero} 12643@!v:integer; {temporary register} 12644begin if t=dependent then threshold:=fraction_threshold 12645else threshold:=scaled_threshold; 12646r:=temp_head; pp:=info(p); qq:=info(q); 12647loop@+ if pp=qq then 12648 if pp=null then goto done 12649 else @<Contribute a term from |p|, plus |f| times the 12650 corresponding term from |q|@> 12651 else if value(pp)<value(qq) then 12652 @<Contribute a term from |q|, multiplied by~|f|@> 12653 else begin link(r):=p; r:=p; p:=link(p); pp:=info(p); 12654 end; 12655done: if t=dependent then 12656 value(p):=slow_add(value(p),take_fraction(value(q),f)) 12657else value(p):=slow_add(value(p),take_scaled(value(q),f)); 12658link(r):=p; dep_final:=p; p_plus_fq:=link(temp_head); 12659end; 12660 12661@ @<Contribute a term from |p|, plus |f|...@>= 12662begin if tt=dependent then v:=value(p)+take_fraction(f,value(q)) 12663else v:=value(p)+take_scaled(f,value(q)); 12664value(p):=v; s:=p; p:=link(p); 12665if abs(v)<threshold then free_node(s,dep_node_size) 12666else begin if abs(v)>=coef_bound then if watch_coefs then 12667 begin type(qq):=independent_needing_fix; fix_needed:=true; 12668 end; 12669 link(r):=s; r:=s; 12670 end; 12671pp:=info(p); q:=link(q); qq:=info(q); 12672end 12673 12674@ @<Contribute a term from |q|, multiplied by~|f|@>= 12675begin if tt=dependent then v:=take_fraction(f,value(q)) 12676else v:=take_scaled(f,value(q)); 12677if abs(v)>half(threshold) then 12678 begin s:=get_node(dep_node_size); info(s):=qq; value(s):=v; 12679 if abs(v)>=coef_bound then if watch_coefs then 12680 begin type(qq):=independent_needing_fix; fix_needed:=true; 12681 end; 12682 link(r):=s; r:=s; 12683 end; 12684q:=link(q); qq:=info(q); 12685end 12686 12687@ It is convenient to have another subroutine for the special case 12688of |p_plus_fq| when |f=1.0|. In this routine lists |p| and |q| are 12689both of the same type~|t| (either |dependent| or |proto_dependent|). 12690 12691@p function p_plus_q(@!p:pointer;@!q:pointer;@!t:small_number):pointer; 12692label done; 12693var @!pp,@!qq:pointer; {|info(p)| and |info(q)|, respectively} 12694@!r,@!s:pointer; {for list manipulation} 12695@!threshold:integer; {defines a neighborhood of zero} 12696@!v:integer; {temporary register} 12697begin if t=dependent then threshold:=fraction_threshold 12698else threshold:=scaled_threshold; 12699r:=temp_head; pp:=info(p); qq:=info(q); 12700loop@+ if pp=qq then 12701 if pp=null then goto done 12702 else @<Contribute a term from |p|, plus the 12703 corresponding term from |q|@> 12704 else if value(pp)<value(qq) then 12705 begin s:=get_node(dep_node_size); info(s):=qq; value(s):=value(q); 12706 q:=link(q); qq:=info(q); link(r):=s; r:=s; 12707 end 12708 else begin link(r):=p; r:=p; p:=link(p); pp:=info(p); 12709 end; 12710done: value(p):=slow_add(value(p),value(q)); 12711link(r):=p; dep_final:=p; p_plus_q:=link(temp_head); 12712end; 12713 12714@ @<Contribute a term from |p|, plus the...@>= 12715begin v:=value(p)+value(q); 12716value(p):=v; s:=p; p:=link(p); pp:=info(p); 12717if abs(v)<threshold then free_node(s,dep_node_size) 12718else begin if abs(v)>=coef_bound then if watch_coefs then 12719 begin type(qq):=independent_needing_fix; fix_needed:=true; 12720 end; 12721 link(r):=s; r:=s; 12722 end; 12723q:=link(q); qq:=info(q); 12724end 12725 12726@ A somewhat simpler routine will multiply a dependency list 12727by a given constant~|v|. The constant is either a |fraction| less than 12728|fraction_one|, or it is |scaled|. In the latter case we might be forced to 12729convert a dependency list to a proto-dependency list. 12730Parameters |t0| and |t1| are the list types before and after; 12731they should agree unless |t0=dependent| and |t1=proto_dependent| 12732and |v_is_scaled=true|. 12733 12734@p function p_times_v(@!p:pointer;@!v:integer; 12735 @!t0,@!t1:small_number;@!v_is_scaled:boolean):pointer; 12736var @!r,@!s:pointer; {for list manipulation} 12737@!w:integer; {tentative coefficient} 12738@!threshold:integer; 12739@!scaling_down:boolean; 12740begin if t0<>t1 then scaling_down:=true@+else scaling_down:=not v_is_scaled; 12741if t1=dependent then threshold:=half_fraction_threshold 12742else threshold:=half_scaled_threshold; 12743r:=temp_head; 12744while info(p)<>null do 12745 begin if scaling_down then w:=take_fraction(v,value(p)) 12746 else w:=take_scaled(v,value(p)); 12747 if abs(w)<=threshold then 12748 begin s:=link(p); free_node(p,dep_node_size); p:=s; 12749 end 12750 else begin if abs(w)>=coef_bound then 12751 begin fix_needed:=true; type(info(p)):=independent_needing_fix; 12752 end; 12753 link(r):=p; r:=p; value(p):=w; p:=link(p); 12754 end; 12755 end; 12756link(r):=p; 12757if v_is_scaled then value(p):=take_scaled(value(p),v) 12758else value(p):=take_fraction(value(p),v); 12759p_times_v:=link(temp_head); 12760end; 12761 12762@ Similarly, we sometimes need to divide a dependency list 12763by a given |scaled| constant. 12764 12765@<Declare basic dependency-list subroutines@>= 12766function p_over_v(@!p:pointer;@!v:scaled; 12767 @!t0,@!t1:small_number):pointer; 12768var @!r,@!s:pointer; {for list manipulation} 12769@!w:integer; {tentative coefficient} 12770@!threshold:integer; 12771@!scaling_down:boolean; 12772begin if t0<>t1 then scaling_down:=true@+else scaling_down:=false; 12773if t1=dependent then threshold:=half_fraction_threshold 12774else threshold:=half_scaled_threshold; 12775r:=temp_head; 12776while info(p)<>null do 12777 begin if scaling_down then 12778 if abs(v)<@'2000000 then w:=make_scaled(value(p),v*@'10000) 12779 else w:=make_scaled(round_fraction(value(p)),v) 12780 else w:=make_scaled(value(p),v); 12781 if abs(w)<=threshold then 12782 begin s:=link(p); free_node(p,dep_node_size); p:=s; 12783 end 12784 else begin if abs(w)>=coef_bound then 12785 begin fix_needed:=true; type(info(p)):=independent_needing_fix; 12786 end; 12787 link(r):=p; r:=p; value(p):=w; p:=link(p); 12788 end; 12789 end; 12790link(r):=p; value(p):=make_scaled(value(p),v); 12791p_over_v:=link(temp_head); 12792end; 12793 12794@ Here's another utility routine for dependency lists. When an independent 12795variable becomes dependent, we want to remove it from all existing 12796dependencies. The |p_with_x_becoming_q| function computes the 12797dependency list of~|p| after variable~|x| has been replaced by~|q|. 12798 12799This procedure has basically the same calling conventions as |p_plus_fq|: 12800List~|q| is unchanged; list~|p| is destroyed; the constant node and the 12801final link are inherited from~|p|; and the fourth parameter tells whether 12802or not |p| is |proto_dependent|. However, the global variable |dep_final| 12803is not altered if |x| does not occur in list~|p|. 12804 12805@p function p_with_x_becoming_q(@!p,@!x,@!q:pointer;@!t:small_number):pointer; 12806var @!r,@!s:pointer; {for list manipulation} 12807@!v:integer; {coefficient of |x|} 12808@!sx:integer; {serial number of |x|} 12809begin s:=p; r:=temp_head; sx:=value(x); 12810while value(info(s))>sx do 12811 begin r:=s; s:=link(s); 12812 end; 12813if info(s)<>x then p_with_x_becoming_q:=p 12814else begin link(temp_head):=p; link(r):=link(s); v:=value(s); 12815 free_node(s,dep_node_size); 12816 p_with_x_becoming_q:=p_plus_fq(link(temp_head),v,q,t,dependent); 12817 end; 12818end; 12819 12820@ Here's a simple procedure that reports an error when a variable 12821has just received a known value that's out of the required range. 12822 12823@<Declare basic dependency-list subroutines@>= 12824procedure val_too_big(@!x:scaled); 12825begin if internal[warning_check]>0 then 12826 begin print_err("Value is too large ("); print_scaled(x); print_char(")"); 12827@.Value is too large@> 12828 help4("The equation I just processed has given some variable")@/ 12829 ("a value of 4096 or more. Continue and I'll try to cope")@/ 12830 ("with that big value; but it might be dangerous.")@/ 12831 ("(Set warningcheck:=0 to suppress this message.)"); 12832 error; 12833 end; 12834end; 12835 12836@ When a dependent variable becomes known, the following routine 12837removes its dependency list. Here |p| points to the variable, and 12838|q| points to the dependency list (which is one node long). 12839 12840@<Declare basic dependency-list subroutines@>= 12841procedure make_known(@!p,@!q:pointer); 12842var @!t:dependent..proto_dependent; {the previous type} 12843begin prev_dep(link(q)):=prev_dep(p); 12844link(prev_dep(p)):=link(q); t:=type(p); 12845type(p):=known; value(p):=value(q); free_node(q,dep_node_size); 12846if abs(value(p))>=fraction_one then val_too_big(value(p)); 12847if internal[tracing_equations]>0 then if interesting(p) then 12848 begin begin_diagnostic; print_nl("#### "); 12849@:]]]\#\#\#\#_}{\.{\#\#\#\#}@> 12850 print_variable_name(p); print_char("="); print_scaled(value(p)); 12851 end_diagnostic(false); 12852 end; 12853if cur_exp=p then if cur_type=t then 12854 begin cur_type:=known; cur_exp:=value(p); 12855 free_node(p,value_node_size); 12856 end; 12857end; 12858 12859@ The |fix_dependencies| routine is called into action when |fix_needed| 12860has been triggered. The program keeps a list~|s| of independent variables 12861whose coefficients must be divided by~4. 12862 12863In unusual cases, this fixup process might reduce one or more coefficients 12864to zero, so that a variable will become known more or less by default. 12865 12866@<Declare basic dependency-list subroutines@>= 12867procedure fix_dependencies; 12868label done; 12869var @!p,@!q,@!r,@!s,@!t:pointer; {list manipulation registers} 12870@!x:pointer; {an independent variable} 12871begin r:=link(dep_head); s:=null; 12872while r<>dep_head do 12873 begin t:=r; 12874 @<Run through the dependency list for variable |t|, fixing 12875 all nodes, and ending with final link~|q|@>; 12876 r:=link(q); 12877 if q=dep_list(t) then make_known(t,q); 12878 end; 12879while s<>null do 12880 begin p:=link(s); x:=info(s); free_avail(s); s:=p; 12881 type(x):=independent; value(x):=value(x)+2; 12882 end; 12883fix_needed:=false; 12884end; 12885 12886@ @d independent_being_fixed=1 {this variable already appears in |s|} 12887 12888@<Run through the dependency list for variable |t|...@>= 12889r:=value_loc(t); {|link(r)=dep_list(t)|} 12890loop@+ begin q:=link(r); x:=info(q); 12891 if x=null then goto done; 12892 if type(x)<=independent_being_fixed then 12893 begin if type(x)<independent_being_fixed then 12894 begin p:=get_avail; link(p):=s; s:=p; 12895 info(s):=x; type(x):=independent_being_fixed; 12896 end; 12897 value(q):=value(q) div 4; 12898 if value(q)=0 then 12899 begin link(r):=link(q); free_node(q,dep_node_size); q:=r; 12900 end; 12901 end; 12902 r:=q; 12903 end; 12904done: 12905 12906@ The |new_dep| routine installs a dependency list~|p| into the value node~|q|, 12907linking it into the list of all known dependencies. We assume that 12908|dep_final| points to the final node of list~|p|. 12909 12910@p procedure new_dep(@!q,@!p:pointer); 12911var @!r:pointer; {what used to be the first dependency} 12912begin dep_list(q):=p; prev_dep(q):=dep_head; 12913r:=link(dep_head); link(dep_final):=r; prev_dep(r):=dep_final; 12914link(dep_head):=q; 12915end; 12916 12917@ Here is one of the ways a dependency list gets started. 12918The |const_dependency| routine produces a list that has nothing but 12919a constant term. 12920 12921@p function const_dependency(@!v:scaled):pointer; 12922begin dep_final:=get_node(dep_node_size); 12923value(dep_final):=v; info(dep_final):=null; 12924const_dependency:=dep_final; 12925end; 12926 12927@ And here's a more interesting way to start a dependency list from scratch: 12928The parameter to |single_dependency| is the location of an 12929independent variable~|x|, and the result is the simple dependency list 12930`|x+0|'. 12931 12932In the unlikely event that the given independent variable has been doubled so 12933often that we can't refer to it with a nonzero coefficient, 12934|single_dependency| returns the simple list `0'. This case can be 12935recognized by testing that the returned list pointer is equal to 12936|dep_final|. 12937 12938@p function single_dependency(@!p:pointer):pointer; 12939var @!q:pointer; {the new dependency list} 12940@!m:integer; {the number of doublings} 12941begin m:=value(p) mod s_scale; 12942if m>28 then single_dependency:=const_dependency(0) 12943else begin q:=get_node(dep_node_size); 12944 value(q):=two_to_the[28-m]; info(q):=p;@/ 12945 link(q):=const_dependency(0); single_dependency:=q; 12946 end; 12947end; 12948 12949@ We sometimes need to make an exact copy of a dependency list. 12950 12951@p function copy_dep_list(@!p:pointer):pointer; 12952label done; 12953var @!q:pointer; {the new dependency list} 12954begin q:=get_node(dep_node_size); dep_final:=q; 12955loop@+ begin info(dep_final):=info(p); value(dep_final):=value(p); 12956 if info(dep_final)=null then goto done; 12957 link(dep_final):=get_node(dep_node_size); 12958 dep_final:=link(dep_final); p:=link(p); 12959 end; 12960done:copy_dep_list:=q; 12961end; 12962 12963@ But how do variables normally become known? Ah, now we get to the heart of the 12964equation-solving mechanism. The |linear_eq| procedure is given a |dependent| 12965or |proto_dependent| list,~|p|, in which at least one independent variable 12966appears. It equates this list to zero, by choosing an independent variable 12967with the largest coefficient and making it dependent on the others. The 12968newly dependent variable is eliminated from all current dependencies, 12969thereby possibly making other dependent variables known. 12970 12971The given list |p| is, of course, totally destroyed by all this processing. 12972 12973@p procedure linear_eq(@!p:pointer;@!t:small_number); 12974var @!q,@!r,@!s:pointer; {for link manipulation} 12975@!x:pointer; {the variable that loses its independence} 12976@!n:integer; {the number of times |x| had been halved} 12977@!v:integer; {the coefficient of |x| in list |p|} 12978@!prev_r:pointer; {lags one step behind |r|} 12979@!final_node:pointer; {the constant term of the new dependency list} 12980@!w:integer; {a tentative coefficient} 12981begin @<Find a node |q| in list |p| whose coefficient |v| is largest@>; 12982x:=info(q); n:=value(x) mod s_scale;@/ 12983@<Divide list |p| by |-v|, removing node |q|@>; 12984if internal[tracing_equations]>0 then @<Display the new dependency@>; 12985@<Simplify all existing dependencies by substituting for |x|@>; 12986@<Change variable |x| from |independent| to |dependent| or |known|@>; 12987if fix_needed then fix_dependencies; 12988end; 12989 12990@ @<Find a node |q| in list |p| whose coefficient |v| is largest@>= 12991q:=p; r:=link(p); v:=value(q); 12992while info(r)<>null do 12993 begin if abs(value(r))>abs(v) then 12994 begin q:=r; v:=value(r); 12995 end; 12996 r:=link(r); 12997 end 12998 12999@ Here we want to change the coefficients from |scaled| to |fraction|, 13000except in the constant term. In the common case of a trivial equation 13001like `\.{x=3.14}', we will have |v=-fraction_one|, |q=p|, and |t=dependent|. 13002 13003@<Divide list |p| by |-v|, removing node |q|@>= 13004s:=temp_head; link(s):=p; r:=p; 13005repeat if r=q then 13006 begin link(s):=link(r); free_node(r,dep_node_size); 13007 end 13008else begin w:=make_fraction(value(r),v); 13009 if abs(w)<=half_fraction_threshold then 13010 begin link(s):=link(r); free_node(r,dep_node_size); 13011 end 13012 else begin value(r):=-w; s:=r; 13013 end; 13014 end; 13015r:=link(s); 13016until info(r)=null; 13017if t=proto_dependent then value(r):=-make_scaled(value(r),v) 13018else if v<>-fraction_one then value(r):=-make_fraction(value(r),v); 13019final_node:=r; p:=link(temp_head) 13020 13021@ @<Display the new dependency@>= 13022if interesting(x) then 13023 begin begin_diagnostic; print_nl("## "); print_variable_name(x); 13024@:]]]\#\#_}{\.{\#\#}@> 13025 w:=n; 13026 while w>0 do 13027 begin print("*4"); w:=w-2; 13028 end; 13029 print_char("="); print_dependency(p,dependent); end_diagnostic(false); 13030 end 13031 13032@ @<Simplify all existing dependencies by substituting for |x|@>= 13033prev_r:=dep_head; r:=link(dep_head); 13034while r<>dep_head do 13035 begin s:=dep_list(r); q:=p_with_x_becoming_q(s,x,p,type(r)); 13036 if info(q)=null then make_known(r,q) 13037 else begin dep_list(r):=q; 13038 repeat q:=link(q); 13039 until info(q)=null; 13040 prev_r:=q; 13041 end; 13042 r:=link(prev_r); 13043 end 13044 13045@ @<Change variable |x| from |independent| to |dependent| or |known|@>= 13046if n>0 then @<Divide list |p| by $2^n$@>; 13047if info(p)=null then 13048 begin type(x):=known; 13049 value(x):=value(p); 13050 if abs(value(x))>=fraction_one then val_too_big(value(x)); 13051 free_node(p,dep_node_size); 13052 if cur_exp=x then if cur_type=independent then 13053 begin cur_exp:=value(x); cur_type:=known; 13054 free_node(x,value_node_size); 13055 end; 13056 end 13057else begin type(x):=dependent; dep_final:=final_node; new_dep(x,p); 13058 if cur_exp=x then if cur_type=independent then cur_type:=dependent; 13059 end 13060 13061@ @<Divide list |p| by $2^n$@>= 13062begin s:=temp_head; link(temp_head):=p; r:=p; 13063repeat if n>30 then w:=0 13064else w:=value(r) div two_to_the[n]; 13065if (abs(w)<=half_fraction_threshold)and(info(r)<>null) then 13066 begin link(s):=link(r); 13067 free_node(r,dep_node_size); 13068 end 13069else begin value(r):=w; s:=r; 13070 end; 13071r:=link(s); 13072until info(s)=null; 13073p:=link(temp_head); 13074end 13075 13076@ The |check_mem| procedure, which is used only when \MF\ is being 13077debugged, makes sure that the current dependency lists are well formed. 13078 13079@<Check the list of linear dependencies@>= 13080q:=dep_head; p:=link(q); 13081while p<>dep_head do 13082 begin if prev_dep(p)<>q then 13083 begin print_nl("Bad PREVDEP at "); print_int(p); 13084@.Bad PREVDEP...@> 13085 end; 13086 p:=dep_list(p); r:=inf_val; 13087 repeat if value(info(p))>=value(r) then 13088 begin print_nl("Out of order at "); print_int(p); 13089@.Out of order...@> 13090 end; 13091 r:=info(p); q:=p; p:=link(q); 13092 until r=null; 13093 end 13094 13095@* \[29] Dynamic nonlinear equations. 13096Variables of numeric type are maintained by the general scheme of 13097independent, dependent, and known values that we have just studied; 13098and the components of pair and transform variables are handled in the 13099same way. But \MF\ also has five other types of values: \&{boolean}, 13100\&{string}, \&{pen}, \&{path}, and \&{picture}; what about them? 13101 13102Equations are allowed between nonlinear quantities, but only in a 13103simple form. Two variables that haven't yet been assigned values are 13104either equal to each other, or they're not. 13105 13106Before a boolean variable has received a value, its type is |unknown_boolean|; 13107similarly, there are variables whose type is |unknown_string|, |unknown_pen|, 13108|unknown_path|, and |unknown_picture|. In such cases the value is either 13109|null| (which means that no other variables are equivalent to this one), or 13110it points to another variable of the same undefined type. The pointers in the 13111latter case form a cycle of nodes, which we shall call a ``ring.'' 13112Rings of undefined variables may include capsules, which arise as 13113intermediate results within expressions or as \&{expr} parameters to macros. 13114 13115When one member of a ring receives a value, the same value is given to 13116all the other members. In the case of paths and pictures, this implies 13117making separate copies of a potentially large data structure; users should 13118restrain their enthusiasm for such generality, unless they have lots and 13119lots of memory space. 13120 13121@ The following procedure is called when a capsule node is being 13122added to a ring (e.g., when an unknown variable is mentioned in an expression). 13123 13124@p function new_ring_entry(@!p:pointer):pointer; 13125var q:pointer; {the new capsule node} 13126begin q:=get_node(value_node_size); name_type(q):=capsule; 13127type(q):=type(p); 13128if value(p)=null then value(q):=p@+else value(q):=value(p); 13129value(p):=q; 13130new_ring_entry:=q; 13131end; 13132 13133@ Conversely, we might delete a capsule or a variable before it becomes known. 13134The following procedure simply detaches a quantity from its ring, 13135without recycling the storage. 13136 13137@<Declare the recycling subroutines@>= 13138procedure ring_delete(@!p:pointer); 13139var @!q:pointer; 13140begin q:=value(p); 13141if q<>null then if q<>p then 13142 begin while value(q)<>p do q:=value(q); 13143 value(q):=value(p); 13144 end; 13145end; 13146 13147@ Eventually there might be an equation that assigns values to all of the 13148variables in a ring. The |nonlinear_eq| subroutine does the necessary 13149propagation of values. 13150 13151If the parameter |flush_p| is |true|, node |p| itself needn't receive a 13152value; it will soon be recycled. 13153 13154@p procedure nonlinear_eq(@!v:integer;@!p:pointer;@!flush_p:boolean); 13155var @!t:small_number; {the type of ring |p|} 13156@!q,@!r:pointer; {link manipulation registers} 13157begin t:=type(p)-unknown_tag; q:=value(p); 13158if flush_p then type(p):=vacuous@+else p:=q; 13159repeat r:=value(q); type(q):=t; 13160case t of 13161boolean_type: value(q):=v; 13162string_type: begin value(q):=v; add_str_ref(v); 13163 end; 13164pen_type: begin value(q):=v; add_pen_ref(v); 13165 end; 13166path_type: value(q):=copy_path(v); 13167picture_type: value(q):=copy_edges(v); 13168end; {there ain't no more cases} 13169q:=r; 13170until q=p; 13171end; 13172 13173@ If two members of rings are equated, and if they have the same type, 13174the |ring_merge| procedure is called on to make them equivalent. 13175 13176@p procedure ring_merge(@!p,@!q:pointer); 13177label exit; 13178var @!r:pointer; {traverses one list} 13179begin r:=value(p); 13180while r<>p do 13181 begin if r=q then 13182 begin @<Exclaim about a redundant equation@>; 13183 return; 13184 end; 13185 r:=value(r); 13186 end; 13187r:=value(p); value(p):=value(q); value(q):=r; 13188exit:end; 13189 13190@ @<Exclaim about a redundant equation@>= 13191begin print_err("Redundant equation");@/ 13192@.Redundant equation@> 13193help2("I already knew that this equation was true.")@/ 13194 ("But perhaps no harm has been done; let's continue.");@/ 13195put_get_error; 13196end 13197 13198@* \[30] Introduction to the syntactic routines. 13199Let's pause a moment now and try to look at the Big Picture. 13200The \MF\ program consists of three main parts: syntactic routines, 13201semantic routines, and output routines. The chief purpose of the 13202syntactic routines is to deliver the user's input to the semantic routines, 13203while parsing expressions and locating operators and operands. The 13204semantic routines act as an interpreter responding to these operators, 13205which may be regarded as commands. And the output routines are 13206periodically called on to produce compact font descriptions that can be 13207used for typesetting or for making interim proof drawings. We have 13208discussed the basic data structures and many of the details of semantic 13209operations, so we are good and ready to plunge into the part of \MF\ that 13210actually controls the activities. 13211 13212Our current goal is to come to grips with the |get_next| procedure, 13213which is the keystone of \MF's input mechanism. Each call of |get_next| 13214sets the value of three variables |cur_cmd|, |cur_mod|, and |cur_sym|, 13215representing the next input token. 13216$$\vbox{\halign{#\hfil\cr 13217 \hbox{|cur_cmd| denotes a command code from the long list of codes 13218 given earlier;}\cr 13219 \hbox{|cur_mod| denotes a modifier of the command code;}\cr 13220 \hbox{|cur_sym| is the hash address of the symbolic token that was 13221 just scanned,}\cr 13222 \hbox{\qquad or zero in the case of a numeric or string 13223 or capsule token.}\cr}}$$ 13224Underlying this external behavior of |get_next| is all the machinery 13225necessary to convert from character files to tokens. At a given time we 13226may be only partially finished with the reading of several files (for 13227which \&{input} was specified), and partially finished with the expansion 13228of some user-defined macros and/or some macro parameters, and partially 13229finished reading some text that the user has inserted online, 13230and so on. When reading a character file, the characters must be 13231converted to tokens; comments and blank spaces must 13232be removed, numeric and string tokens must be evaluated. 13233 13234To handle these situations, which might all be present simultaneously, 13235\MF\ uses various stacks that hold information about the incomplete 13236activities, and there is a finite state control for each level of the 13237input mechanism. These stacks record the current state of an implicitly 13238recursive process, but the |get_next| procedure is not recursive. 13239 13240@<Glob...@>= 13241@!cur_cmd: eight_bits; {current command set by |get_next|} 13242@!cur_mod: integer; {operand of current command} 13243@!cur_sym: halfword; {hash address of current symbol} 13244 13245@ The |print_cmd_mod| routine prints a symbolic interpretation of a 13246command code and its modifier. 13247It consists of a rather tedious sequence of print 13248commands, and most of it is essentially an inverse to the |primitive| 13249routine that enters a \MF\ primitive into |hash| and |eqtb|. Therefore almost 13250all of this procedure appears elsewhere in the program, together with the 13251corresponding |primitive| calls. 13252 13253@<Declare the procedure called |print_cmd_mod|@>= 13254procedure print_cmd_mod(@!c,@!m:integer); 13255begin case c of 13256@t\4@>@<Cases of |print_cmd_mod| for symbolic printing of primitives@>@/ 13257othercases print("[unknown command code!]") 13258endcases; 13259end; 13260 13261@ Here is a procedure that displays a given command in braces, in the 13262user's transcript file. 13263 13264@d show_cur_cmd_mod==show_cmd_mod(cur_cmd,cur_mod) 13265 13266@p procedure show_cmd_mod(@!c,@!m:integer); 13267begin begin_diagnostic; print_nl("{"); 13268print_cmd_mod(c,m); print_char("}"); 13269end_diagnostic(false); 13270end; 13271 13272@* \[31] Input stacks and states. 13273The state of \MF's input mechanism appears in the input stack, whose 13274entries are records with five fields, called |index|, |start|, |loc|, 13275|limit|, and |name|. The top element of this stack is maintained in a 13276global variable for which no subscripting needs to be done; the other 13277elements of the stack appear in an array. Hence the stack is declared thus: 13278 13279@<Types...@>= 13280@!in_state_record = record 13281 @!index_field: quarterword; 13282 @!start_field,@!loc_field, @!limit_field, @!name_field: halfword; 13283 end; 13284 13285@ @<Glob...@>= 13286@!input_stack : array[0..stack_size] of in_state_record; 13287@!input_ptr : 0..stack_size; {first unused location of |input_stack|} 13288@!max_in_stack: 0..stack_size; {largest value of |input_ptr| when pushing} 13289@!cur_input : in_state_record; {the ``top'' input state} 13290 13291@ We've already defined the special variable |@!loc==cur_input.loc_field| 13292in our discussion of basic input-output routines. The other components of 13293|cur_input| are defined in the same way: 13294 13295@d index==cur_input.index_field {reference for buffer information} 13296@d start==cur_input.start_field {starting position in |buffer|} 13297@d limit==cur_input.limit_field {end of current line in |buffer|} 13298@d name==cur_input.name_field {name of the current file} 13299 13300@ Let's look more closely now at the five control variables 13301(|index|,~|start|,~|loc|,~|limit|,~|name|), 13302assuming that \MF\ is reading a line of characters that have been input 13303from some file or from the user's terminal. There is an array called 13304|buffer| that acts as a stack of all lines of characters that are 13305currently being read from files, including all lines on subsidiary 13306levels of the input stack that are not yet completed. \MF\ will return to 13307the other lines when it is finished with the present input file. 13308 13309(Incidentally, on a machine with byte-oriented addressing, it would be 13310appropriate to combine |buffer| with the |str_pool| array, 13311letting the buffer entries grow downward from the top of the string pool 13312and checking that these two tables don't bump into each other.) 13313 13314The line we are currently working on begins in position |start| of the 13315buffer; the next character we are about to read is |buffer[loc]|; and 13316|limit| is the location of the last character present. We always have 13317|loc<=limit|. For convenience, |buffer[limit]| has been set to |"%"|, so 13318that the end of a line is easily sensed. 13319 13320The |name| variable is a string number that designates the name of 13321the current file, if we are reading a text file. It is 0 if we 13322are reading from the terminal for normal input, or 1 if we are executing a 13323\&{readstring} command, or 2 if we are reading a string that was 13324moved into the buffer by \&{scantokens}. 13325 13326@ Additional information about the current line is available via the 13327|index| variable, which counts how many lines of characters are present 13328in the buffer below the current level. We have |index=0| when reading 13329from the terminal and prompting the user for each line; then if the user types, 13330e.g., `\.{input font}', we will have |index=1| while reading 13331the file \.{font.mf}. However, it does not follow that |index| is the 13332same as the input stack pointer, since many of the levels on the input 13333stack may come from token lists. 13334 13335The global variable |in_open| is equal to the |index| 13336value of the highest non-token-list level. Thus, the number of partially read 13337lines in the buffer is |in_open+1|, and we have |in_open=index| 13338when we are not reading a token list. 13339 13340If we are not currently reading from the terminal, 13341we are reading from the file variable |input_file[index]|. We use 13342the notation |terminal_input| as a convenient abbreviation for |name=0|, 13343and |cur_file| as an abbreviation for |input_file[index]|. 13344 13345The global variable |line| contains the line number in the topmost 13346open file, for use in error messages. If we are not reading from 13347the terminal, |line_stack[index]| holds the line number for the 13348enclosing level, so that |line| can be restored when the current 13349file has been read. 13350 13351If more information about the input state is needed, it can be 13352included in small arrays like those shown here. For example, 13353the current page or segment number in the input file might be 13354put into a variable |@!page|, maintained for enclosing levels in 13355`\ignorespaces|@!page_stack:array[1..max_in_open] of integer|\unskip' 13356by analogy with |line_stack|. 13357@^system dependencies@> 13358 13359@d terminal_input==(name=0) {are we reading from the terminal?} 13360@d cur_file==input_file[index] {the current |alpha_file| variable} 13361 13362@<Glob...@>= 13363@!in_open : 0..max_in_open; {the number of lines in the buffer, less one} 13364@!open_parens : 0..max_in_open; {the number of open text files} 13365@!input_file : array[1..max_in_open] of alpha_file; 13366@!line : integer; {current line number in the current source file} 13367@!line_stack : array[1..max_in_open] of integer; 13368 13369@ However, all this discussion about input state really applies only to the 13370case that we are inputting from a file. There is another important case, 13371namely when we are currently getting input from a token list. In this case 13372|index>max_in_open|, and the conventions about the other state variables 13373are different: 13374 13375\yskip\hang|loc| is a pointer to the current node in the token list, i.e., 13376the node that will be read next. If |loc=null|, the token list has been 13377fully read. 13378 13379\yskip\hang|start| points to the first node of the token list; this node 13380may or may not contain a reference count, depending on the type of token 13381list involved. 13382 13383\yskip\hang|token_type|, which takes the place of |index| in the 13384discussion above, is a code number that explains what kind of token list 13385is being scanned. 13386 13387\yskip\hang|name| points to the |eqtb| address of the control sequence 13388being expanded, if the current token list is a macro not defined by 13389\&{vardef}. Macros defined by \&{vardef} have |name=null|; their name 13390can be deduced by looking at their first two parameters. 13391 13392\yskip\hang|param_start|, which takes the place of |limit|, tells where 13393the parameters of the current macro or loop text begin in the |param_stack|. 13394 13395\yskip\noindent The |token_type| can take several values, depending on 13396where the current token list came from: 13397 13398\yskip 13399\indent|forever_text|, if the token list being scanned is the body of 13400a \&{forever} loop; 13401 13402\indent|loop_text|, if the token list being scanned is the body of 13403a \&{for} or \&{forsuffixes} loop; 13404 13405\indent|parameter|, if a \&{text} or \&{suffix} parameter is being scanned; 13406 13407\indent|backed_up|, if the token list being scanned has been inserted as 13408`to be read again'. 13409 13410\indent|inserted|, if the token list being scanned has been inserted as 13411part of error recovery; 13412 13413\indent|macro|, if the expansion of a user-defined symbolic token is being 13414scanned. 13415 13416\yskip\noindent 13417The token list begins with a reference count if and only if |token_type= 13418macro|. 13419@^reference counts@> 13420 13421@d token_type==index {type of current token list} 13422@d token_state==(index>max_in_open) {are we scanning a token list?} 13423@d file_state==(index<=max_in_open) {are we scanning a file line?} 13424@d param_start==limit {base of macro parameters in |param_stack|} 13425@d forever_text=max_in_open+1 {|token_type| code for loop texts} 13426@d loop_text=max_in_open+2 {|token_type| code for loop texts} 13427@d parameter=max_in_open+3 {|token_type| code for parameter texts} 13428@d backed_up=max_in_open+4 {|token_type| code for texts to be reread} 13429@d inserted=max_in_open+5 {|token_type| code for inserted texts} 13430@d macro=max_in_open+6 {|token_type| code for macro replacement texts} 13431 13432@ The |param_stack| is an auxiliary array used to hold pointers to the token 13433lists for parameters at the current level and subsidiary levels of input. 13434This stack grows at a different rate from the others. 13435 13436@<Glob...@>= 13437@!param_stack:array [0..param_size] of pointer; 13438 {token list pointers for parameters} 13439@!param_ptr:0..param_size; {first unused entry in |param_stack|} 13440@!max_param_stack:integer; 13441 {largest value of |param_ptr|} 13442 13443@ Thus, the ``current input state'' can be very complicated indeed; there 13444can be many levels and each level can arise in a variety of ways. The 13445|show_context| procedure, which is used by \MF's error-reporting routine to 13446print out the current input state on all levels down to the most recent 13447line of characters from an input file, illustrates most of these conventions. 13448The global variable |file_ptr| contains the lowest level that was 13449displayed by this procedure. 13450 13451@<Glob...@>= 13452@!file_ptr:0..stack_size; {shallowest level shown by |show_context|} 13453 13454@ The status at each level is indicated by printing two lines, where the first 13455line indicates what was read so far and the second line shows what remains 13456to be read. The context is cropped, if necessary, so that the first line 13457contains at most |half_error_line| characters, and the second contains 13458at most |error_line|. Non-current input levels whose |token_type| is 13459`|backed_up|' are shown only if they have not been fully read. 13460 13461@p procedure show_context; {prints where the scanner is} 13462label done; 13463var @!old_setting:0..max_selector; {saved |selector| setting} 13464@<Local variables for formatting calculations@>@/ 13465begin file_ptr:=input_ptr; input_stack[file_ptr]:=cur_input; 13466 {store current state} 13467loop@+begin cur_input:=input_stack[file_ptr]; {enter into the context} 13468 @<Display the current context@>; 13469 if file_state then 13470 if (name>2) or (file_ptr=0) then goto done; 13471 decr(file_ptr); 13472 end; 13473done: cur_input:=input_stack[input_ptr]; {restore original state} 13474end; 13475 13476@ @<Display the current context@>= 13477if (file_ptr=input_ptr) or file_state or 13478 (token_type<>backed_up) or (loc<>null) then 13479 {we omit backed-up token lists that have already been read} 13480 begin tally:=0; {get ready to count characters} 13481 old_setting:=selector; 13482 if file_state then 13483 begin @<Print location of current line@>; 13484 @<Pseudoprint the line@>; 13485 end 13486 else begin @<Print type of token list@>; 13487 @<Pseudoprint the token list@>; 13488 end; 13489 selector:=old_setting; {stop pseudoprinting} 13490 @<Print two lines using the tricky pseudoprinted information@>; 13491 end 13492 13493@ This routine should be changed, if necessary, to give the best possible 13494indication of where the current line resides in the input file. 13495For example, on some systems it is best to print both a page and line number. 13496@^system dependencies@> 13497 13498@<Print location of current line@>= 13499if name<=1 then 13500 if terminal_input and(file_ptr=0) then print_nl("<*>") 13501 else print_nl("<insert>") 13502else if name=2 then print_nl("<scantokens>") 13503else begin print_nl("l."); print_int(line); 13504 end; 13505print_char(" ") 13506 13507@ @<Print type of token list@>= 13508case token_type of 13509forever_text: print_nl("<forever> "); 13510loop_text: @<Print the current loop value@>; 13511parameter: print_nl("<argument> "); 13512backed_up: if loc=null then print_nl("<recently read> ") 13513 else print_nl("<to be read again> "); 13514inserted: print_nl("<inserted text> "); 13515macro: begin print_ln; 13516 if name<>null then slow_print(text(name)) 13517 else @<Print the name of a \&{vardef}'d macro@>; 13518 print("->"); 13519 end; 13520othercases print_nl("?") {this should never happen} 13521@.?\relax@> 13522endcases 13523 13524@ The parameter that corresponds to a loop text is either a token list 13525(in the case of \&{forsuffixes}) or a ``capsule'' (in the case of \&{for}). 13526We'll discuss capsules later; for now, all we need to know is that 13527the |link| field in a capsule parameter is |void| and that 13528|print_exp(p,0)| displays the value of capsule~|p| in abbreviated form. 13529 13530@<Print the current loop value@>= 13531begin print_nl("<for("); p:=param_stack[param_start]; 13532if p<>null then 13533 if link(p)=void then print_exp(p,0) {we're in a \&{for} loop} 13534 else show_token_list(p,null,20,tally); 13535print(")> "); 13536end 13537 13538@ The first two parameters of a macro defined by \&{vardef} will be token 13539lists representing the macro's prefix and ``at point.'' By putting these 13540together, we get the macro's full name. 13541 13542@<Print the name of a \&{vardef}'d macro@>= 13543begin p:=param_stack[param_start]; 13544if p=null then show_token_list(param_stack[param_start+1],null,20,tally) 13545else begin q:=p; 13546 while link(q)<>null do q:=link(q); 13547 link(q):=param_stack[param_start+1]; 13548 show_token_list(p,null,20,tally); 13549 link(q):=null; 13550 end; 13551end 13552 13553@ Now it is necessary to explain a little trick. We don't want to store a long 13554string that corresponds to a token list, because that string might take up 13555lots of memory; and we are printing during a time when an error message is 13556being given, so we dare not do anything that might overflow one of \MF's 13557tables. So `pseudoprinting' is the answer: We enter a mode of printing 13558that stores characters into a buffer of length |error_line|, where character 13559$k+1$ is placed into \hbox{|trick_buf[k mod error_line]|} if 13560|k<trick_count|, otherwise character |k| is dropped. Initially we set 13561|tally:=0| and |trick_count:=1000000|; then when we reach the 13562point where transition from line 1 to line 2 should occur, we 13563set |first_count:=tally| and |trick_count:=@tmax@>(error_line, 13564tally+1+error_line-half_error_line)|. At the end of the 13565pseudoprinting, the values of |first_count|, |tally|, and 13566|trick_count| give us all the information we need to print the two lines, 13567and all of the necessary text is in |trick_buf|. 13568 13569Namely, let |l| be the length of the descriptive information that appears 13570on the first line. The length of the context information gathered for that 13571line is |k=first_count|, and the length of the context information 13572gathered for line~2 is $m=\min(|tally|, |trick_count|)-k$. If |l+k<=h|, 13573where |h=half_error_line|, we print |trick_buf[0..k-1]| after the 13574descriptive information on line~1, and set |n:=l+k|; here |n| is the 13575length of line~1. If $l+k>h$, some cropping is necessary, so we set |n:=h| 13576and print `\.{...}' followed by 13577$$\hbox{|trick_buf[(l+k-h+3)..k-1]|,}$$ 13578where subscripts of |trick_buf| are circular modulo |error_line|. The 13579second line consists of |n|~spaces followed by |trick_buf[k..(k+m-1)]|, 13580unless |n+m>error_line|; in the latter case, further cropping is done. 13581This is easier to program than to explain. 13582 13583@<Local variables for formatting...@>= 13584@!i:0..buf_size; {index into |buffer|} 13585@!l:integer; {length of descriptive information on line 1} 13586@!m:integer; {context information gathered for line 2} 13587@!n:0..error_line; {length of line 1} 13588@!p: integer; {starting or ending place in |trick_buf|} 13589@!q: integer; {temporary index} 13590 13591@ The following code tells the print routines to gather 13592the desired information. 13593 13594@d begin_pseudoprint== 13595 begin l:=tally; tally:=0; selector:=pseudo; 13596 trick_count:=1000000; 13597 end 13598@d set_trick_count== 13599 begin first_count:=tally; 13600 trick_count:=tally+1+error_line-half_error_line; 13601 if trick_count<error_line then trick_count:=error_line; 13602 end 13603 13604@ And the following code uses the information after it has been gathered. 13605 13606@<Print two lines using the tricky pseudoprinted information@>= 13607if trick_count=1000000 then set_trick_count; 13608 {|set_trick_count| must be performed} 13609if tally<trick_count then m:=tally-first_count 13610else m:=trick_count-first_count; {context on line 2} 13611if l+first_count<=half_error_line then 13612 begin p:=0; n:=l+first_count; 13613 end 13614else begin print("..."); p:=l+first_count-half_error_line+3; 13615 n:=half_error_line; 13616 end; 13617for q:=p to first_count-1 do print_char(trick_buf[q mod error_line]); 13618print_ln; 13619for q:=1 to n do print_char(" "); {print |n| spaces to begin line~2} 13620if m+n<=error_line then p:=first_count+m else p:=first_count+(error_line-n-3); 13621for q:=first_count to p-1 do print_char(trick_buf[q mod error_line]); 13622if m+n>error_line then print("...") 13623 13624@ But the trick is distracting us from our current goal, which is to 13625understand the input state. So let's concentrate on the data structures that 13626are being pseudoprinted as we finish up the |show_context| procedure. 13627 13628@<Pseudoprint the line@>= 13629begin_pseudoprint; 13630if limit>0 then for i:=start to limit-1 do 13631 begin if i=loc then set_trick_count; 13632 print(buffer[i]); 13633 end 13634 13635@ @<Pseudoprint the token list@>= 13636begin_pseudoprint; 13637if token_type<>macro then show_token_list(start,loc,100000,0) 13638else show_macro(start,loc,100000) 13639 13640@ Here is the missing piece of |show_token_list| that is activated when the 13641token beginning line~2 is about to be shown: 13642 13643@<Do magic computation@>=set_trick_count 13644 13645@* \[32] Maintaining the input stacks. 13646The following subroutines change the input status in commonly needed ways. 13647 13648First comes |push_input|, which stores the current state and creates a 13649new level (having, initially, the same properties as the old). 13650 13651@d push_input==@t@> {enter a new input level, save the old} 13652 begin if input_ptr>max_in_stack then 13653 begin max_in_stack:=input_ptr; 13654 if input_ptr=stack_size then overflow("input stack size",stack_size); 13655@:METAFONT capacity exceeded input stack size}{\quad input stack size@> 13656 end; 13657 input_stack[input_ptr]:=cur_input; {stack the record} 13658 incr(input_ptr); 13659 end 13660 13661@ And of course what goes up must come down. 13662 13663@d pop_input==@t@> {leave an input level, re-enter the old} 13664 begin decr(input_ptr); cur_input:=input_stack[input_ptr]; 13665 end 13666 13667@ Here is a procedure that starts a new level of token-list input, given 13668a token list |p| and its type |t|. If |t=macro|, the calling routine should 13669set |name|, reset~|loc|, and increase the macro's reference count. 13670 13671@d back_list(#)==begin_token_list(#,backed_up) {backs up a simple token list} 13672 13673@p procedure begin_token_list(@!p:pointer;@!t:quarterword); 13674begin push_input; start:=p; token_type:=t; 13675param_start:=param_ptr; loc:=p; 13676end; 13677 13678@ When a token list has been fully scanned, the following computations 13679should be done as we leave that level of input. 13680@^inner loop@> 13681 13682@p procedure end_token_list; {leave a token-list input level} 13683label done; 13684var @!p:pointer; {temporary register} 13685begin if token_type>=backed_up then {token list to be deleted} 13686 if token_type<=inserted then 13687 begin flush_token_list(start); goto done; 13688 end 13689 else delete_mac_ref(start); {update reference count} 13690while param_ptr>param_start do {parameters must be flushed} 13691 begin decr(param_ptr); 13692 p:=param_stack[param_ptr]; 13693 if p<>null then 13694 if link(p)=void then {it's an \&{expr} parameter} 13695 begin recycle_value(p); free_node(p,value_node_size); 13696 end 13697 else flush_token_list(p); {it's a \&{suffix} or \&{text} parameter} 13698 end; 13699done: pop_input; check_interrupt; 13700end; 13701 13702@ The contents of |cur_cmd,cur_mod,cur_sym| are placed into an equivalent 13703token by the |cur_tok| routine. 13704@^inner loop@> 13705 13706@p @t\4@>@<Declare the procedure called |make_exp_copy|@>@;@/ 13707function cur_tok:pointer; 13708var @!p:pointer; {a new token node} 13709@!save_type:small_number; {|cur_type| to be restored} 13710@!save_exp:integer; {|cur_exp| to be restored} 13711begin if cur_sym=0 then 13712 if cur_cmd=capsule_token then 13713 begin save_type:=cur_type; save_exp:=cur_exp; 13714 make_exp_copy(cur_mod); p:=stash_cur_exp; link(p):=null; 13715 cur_type:=save_type; cur_exp:=save_exp; 13716 end 13717 else begin p:=get_node(token_node_size); 13718 value(p):=cur_mod; name_type(p):=token; 13719 if cur_cmd=numeric_token then type(p):=known 13720 else type(p):=string_type; 13721 end 13722else begin fast_get_avail(p); info(p):=cur_sym; 13723 end; 13724cur_tok:=p; 13725end; 13726 13727@ Sometimes \MF\ has read too far and wants to ``unscan'' what it has 13728seen. The |back_input| procedure takes care of this by putting the token 13729just scanned back into the input stream, ready to be read again. 13730If |cur_sym<>0|, the values of |cur_cmd| and |cur_mod| are irrelevant. 13731 13732@p procedure back_input; {undoes one token of input} 13733var @!p:pointer; {a token list of length one} 13734begin p:=cur_tok; 13735while token_state and(loc=null) do end_token_list; {conserve stack space} 13736back_list(p); 13737end; 13738 13739@ The |back_error| routine is used when we want to restore or replace an 13740offending token just before issuing an error message. We disable interrupts 13741during the call of |back_input| so that the help message won't be lost. 13742 13743@p procedure back_error; {back up one token and call |error|} 13744begin OK_to_interrupt:=false; back_input; OK_to_interrupt:=true; error; 13745end; 13746@# 13747procedure ins_error; {back up one inserted token and call |error|} 13748begin OK_to_interrupt:=false; back_input; token_type:=inserted; 13749OK_to_interrupt:=true; error; 13750end; 13751 13752@ The |begin_file_reading| procedure starts a new level of input for lines 13753of characters to be read from a file, or as an insertion from the 13754terminal. It does not take care of opening the file, nor does it set |loc| 13755or |limit| or |line|. 13756@^system dependencies@> 13757 13758@p procedure begin_file_reading; 13759begin if in_open=max_in_open then overflow("text input levels",max_in_open); 13760@:METAFONT capacity exceeded text input levels}{\quad text input levels@> 13761if first=buf_size then overflow("buffer size",buf_size); 13762@:METAFONT capacity exceeded buffer size}{\quad buffer size@> 13763incr(in_open); push_input; index:=in_open; 13764line_stack[index]:=line; start:=first; 13765name:=0; {|terminal_input| is now |true|} 13766end; 13767 13768@ Conversely, the variables must be downdated when such a level of input 13769is finished: 13770 13771@p procedure end_file_reading; 13772begin first:=start; line:=line_stack[index]; 13773if index<>in_open then confusion("endinput"); 13774@:this can't happen endinput}{\quad endinput@> 13775if name>2 then a_close(cur_file); {forget it} 13776pop_input; decr(in_open); 13777end; 13778 13779@ In order to keep the stack from overflowing during a long sequence of 13780inserted `\.{show}' commands, the following routine removes completed 13781error-inserted lines from memory. 13782 13783@p procedure clear_for_error_prompt; 13784begin while file_state and terminal_input and@| 13785 (input_ptr>0)and(loc=limit) do end_file_reading; 13786print_ln; clear_terminal; 13787end; 13788 13789@ To get \MF's whole input mechanism going, we perform the following 13790actions. 13791 13792@<Initialize the input routines@>= 13793begin input_ptr:=0; max_in_stack:=0; 13794in_open:=0; open_parens:=0; max_buf_stack:=0; 13795param_ptr:=0; max_param_stack:=0; 13796first:=1; 13797start:=1; index:=0; line:=0; name:=0; 13798force_eof:=false; 13799if not init_terminal then goto final_end; 13800limit:=last; first:=last+1; {|init_terminal| has set |loc| and |last|} 13801end; 13802 13803@* \[33] Getting the next token. 13804The heart of \MF's input mechanism is the |get_next| procedure, which 13805we shall develop in the next few sections of the program. Perhaps we 13806shouldn't actually call it the ``heart,'' however; it really acts as \MF's 13807eyes and mouth, reading the source files and gobbling them up. And it also 13808helps \MF\ to regurgitate stored token lists that are to be processed again. 13809 13810The main duty of |get_next| is to input one token and to set |cur_cmd| 13811and |cur_mod| to that token's command code and modifier. Furthermore, if 13812the input token is a symbolic token, that token's |hash| address 13813is stored in |cur_sym|; otherwise |cur_sym| is set to zero. 13814 13815Underlying this simple description is a certain amount of complexity 13816because of all the cases that need to be handled. 13817However, the inner loop of |get_next| is reasonably short and fast. 13818 13819@ Before getting into |get_next|, we need to consider a mechanism by which 13820\MF\ helps keep errors from propagating too far. Whenever the program goes 13821into a mode where it keeps calling |get_next| repeatedly until a certain 13822condition is met, it sets |scanner_status| to some value other than |normal|. 13823Then if an input file ends, or if an `\&{outer}' symbol appears, 13824an appropriate error recovery will be possible. 13825 13826The global variable |warning_info| helps in this error recovery by providing 13827additional information. For example, |warning_info| might indicate the 13828name of a macro whose replacement text is being scanned. 13829 13830@d normal=0 {|scanner_status| at ``quiet times''} 13831@d skipping=1 {|scanner_status| when false conditional text is being skipped} 13832@d flushing=2 {|scanner_status| when junk after a statement is being ignored} 13833@d absorbing=3 {|scanner_status| when a \&{text} parameter is being scanned} 13834@d var_defining=4 {|scanner_status| when a \&{vardef} is being scanned} 13835@d op_defining=5 {|scanner_status| when a macro \&{def} is being scanned} 13836@d loop_defining=6 {|scanner_status| when a \&{for} loop is being scanned} 13837 13838@<Glob...@>= 13839@!scanner_status:normal..loop_defining; {are we scanning at high speed?} 13840@!warning_info:integer; {if so, what else do we need to know, 13841 in case an error occurs?} 13842 13843@ @<Initialize the input routines@>= 13844scanner_status:=normal; 13845 13846@ The following subroutine 13847is called when an `\&{outer}' symbolic token has been scanned or 13848when the end of a file has been reached. These two cases are distinguished 13849by |cur_sym|, which is zero at the end of a file. 13850 13851@p function check_outer_validity:boolean; 13852var @!p:pointer; {points to inserted token list} 13853begin if scanner_status=normal then check_outer_validity:=true 13854else begin deletions_allowed:=false; 13855 @<Back up an outer symbolic token so that it can be reread@>; 13856 if scanner_status>skipping then 13857 @<Tell the user what has run away and try to recover@> 13858 else begin print_err("Incomplete if; all text was ignored after line "); 13859@.Incomplete if...@> 13860 print_int(warning_info);@/ 13861 help3("A forbidden `outer' token occurred in skipped text.")@/ 13862 ("This kind of error happens when you say `if...' and forget")@/ 13863 ("the matching `fi'. I've inserted a `fi'; this might work."); 13864 if cur_sym=0 then help_line[2]:=@| 13865 "The file ended while I was skipping conditional text."; 13866 cur_sym:=frozen_fi; ins_error; 13867 end; 13868 deletions_allowed:=true; check_outer_validity:=false; 13869 end; 13870end; 13871 13872@ @<Back up an outer symbolic token so that it can be reread@>= 13873if cur_sym<>0 then 13874 begin p:=get_avail; info(p):=cur_sym; 13875 back_list(p); {prepare to read the symbolic token again} 13876 end 13877 13878@ @<Tell the user what has run away...@>= 13879begin runaway; {print the definition-so-far} 13880if cur_sym=0 then print_err("File ended") 13881@.File ended while scanning...@> 13882else begin print_err("Forbidden token found"); 13883@.Forbidden token found...@> 13884 end; 13885print(" while scanning "); 13886help4("I suspect you have forgotten an `enddef',")@/ 13887("causing me to read past where you wanted me to stop.")@/ 13888("I'll try to recover; but if the error is serious,")@/ 13889("you'd better type `E' or `X' now and fix your file.");@/ 13890case scanner_status of 13891@t\4@>@<Complete the error message, 13892 and set |cur_sym| to a token that might help recover from the error@>@; 13893end; {there are no other cases} 13894ins_error; 13895end 13896 13897@ As we consider various kinds of errors, it is also appropriate to 13898change the first line of the help message just given; |help_line[3]| 13899points to the string that might be changed. 13900 13901@<Complete the error message,...@>= 13902flushing: begin print("to the end of the statement"); 13903 help_line[3]:="A previous error seems to have propagated,"; 13904 cur_sym:=frozen_semicolon; 13905 end; 13906absorbing: begin print("a text argument"); 13907 help_line[3]:="It seems that a right delimiter was left out,"; 13908 if warning_info=0 then cur_sym:=frozen_end_group 13909 else begin cur_sym:=frozen_right_delimiter; 13910 equiv(frozen_right_delimiter):=warning_info; 13911 end; 13912 end; 13913var_defining, op_defining: begin print("the definition of "); 13914 if scanner_status=op_defining then slow_print(text(warning_info)) 13915 else print_variable_name(warning_info); 13916 cur_sym:=frozen_end_def; 13917 end; 13918loop_defining: begin print("the text of a "); slow_print(text(warning_info)); 13919 print(" loop"); 13920 help_line[3]:="I suspect you have forgotten an `endfor',"; 13921 cur_sym:=frozen_end_for; 13922 end; 13923 13924@ The |runaway| procedure displays the first part of the text that occurred 13925when \MF\ began its special |scanner_status|, if that text has been saved. 13926 13927@<Declare the procedure called |runaway|@>= 13928procedure runaway; 13929begin if scanner_status>flushing then 13930 begin print_nl("Runaway "); 13931 case scanner_status of 13932 absorbing: print("text?"); 13933 var_defining,op_defining: print("definition?"); 13934 loop_defining: print("loop?"); 13935 end; {there are no other cases} 13936 print_ln; show_token_list(link(hold_head),null,error_line-10,0); 13937 end; 13938end; 13939 13940@ We need to mention a procedure that may be called by |get_next|. 13941 13942@p procedure@?firm_up_the_line; forward; 13943 13944@ And now we're ready to take the plunge into |get_next| itself. 13945 13946@d switch=25 {a label in |get_next|} 13947@d start_numeric_token=85 {another} 13948@d start_decimal_token=86 {and another} 13949@d fin_numeric_token=87 13950 {and still another, although |goto| is considered harmful} 13951 13952@p procedure get_next; {sets |cur_cmd|, |cur_mod|, |cur_sym| to next token} 13953@^inner loop@> 13954label restart, {go here to get the next input token} 13955 exit, {go here when the next input token has been got} 13956 found, {go here when the end of a symbolic token has been found} 13957 switch, {go here to branch on the class of an input character} 13958 start_numeric_token,start_decimal_token,fin_numeric_token,done; 13959 {go here at crucial stages when scanning a number} 13960var @!k:0..buf_size; {an index into |buffer|} 13961@!c:ASCII_code; {the current character in the buffer} 13962@!class:ASCII_code; {its class number} 13963@!n,@!f:integer; {registers for decimal-to-binary conversion} 13964begin restart: cur_sym:=0; 13965if file_state then 13966@<Input from external file; |goto restart| if no input found, 13967 or |return| if a non-symbolic token is found@> 13968else @<Input from token list; |goto restart| if end of list or 13969 if a parameter needs to be expanded, 13970 or |return| if a non-symbolic token is found@>; 13971@<Finish getting the symbolic token in |cur_sym|; 13972 |goto restart| if it is illegal@>; 13973exit:end; 13974 13975@ When a symbolic token is declared to be `\&{outer}', its command code 13976is increased by |outer_tag|. 13977@^inner loop@> 13978 13979@<Finish getting the symbolic token in |cur_sym|...@>= 13980cur_cmd:=eq_type(cur_sym); cur_mod:=equiv(cur_sym); 13981if cur_cmd>=outer_tag then 13982 if check_outer_validity then cur_cmd:=cur_cmd-outer_tag 13983 else goto restart 13984 13985@ A percent sign appears in |buffer[limit]|; this makes it unnecessary 13986to have a special test for end-of-line. 13987@^inner loop@> 13988 13989@<Input from external file;...@>= 13990begin switch: c:=buffer[loc]; incr(loc); class:=char_class[c]; 13991case class of 13992digit_class: goto start_numeric_token; 13993period_class: begin class:=char_class[buffer[loc]]; 13994 if class>period_class then goto switch 13995 else if class<period_class then {|class=digit_class|} 13996 begin n:=0; goto start_decimal_token; 13997 end; 13998@:. }{\..\ token@> 13999 end; 14000space_class: goto switch; 14001percent_class: begin @<Move to next line of file, 14002 or |goto restart| if there is no next line@>; 14003 check_interrupt; 14004 goto switch; 14005 end; 14006string_class: @<Get a string token and |return|@>; 14007isolated_classes: begin k:=loc-1; goto found; 14008 end; 14009invalid_class: @<Decry the invalid character and |goto restart|@>; 14010othercases do_nothing {letters, etc.} 14011endcases;@/ 14012k:=loc-1; 14013while char_class[buffer[loc]]=class do incr(loc); 14014goto found; 14015start_numeric_token:@<Get the integer part |n| of a numeric token; 14016 set |f:=0| and |goto fin_numeric_token| if there is no decimal point@>; 14017start_decimal_token:@<Get the fraction part |f| of a numeric token@>; 14018fin_numeric_token:@<Pack the numeric and fraction parts of a numeric token 14019 and |return|@>; 14020found: cur_sym:=id_lookup(k,loc-k); 14021end 14022 14023@ We go to |restart| instead of to |switch|, because we might enter 14024|token_state| after the error has been dealt with 14025(cf.\ |clear_for_error_prompt|). 14026 14027@<Decry the invalid...@>= 14028begin print_err("Text line contains an invalid character"); 14029@.Text line contains...@> 14030help2("A funny symbol that I can't read has just been input.")@/ 14031("Continue, and I'll forget that it ever happened.");@/ 14032deletions_allowed:=false; error; deletions_allowed:=true; 14033goto restart; 14034end 14035 14036@ @<Get a string token and |return|@>= 14037begin if buffer[loc]="""" then cur_mod:="" 14038else begin k:=loc; buffer[limit+1]:=""""; 14039 repeat incr(loc); 14040 until buffer[loc]=""""; 14041 if loc>limit then @<Decry the missing string delimiter and |goto restart|@>; 14042 if (loc=k+1) and (length(buffer[k])=1) then cur_mod:=buffer[k] 14043 else begin str_room(loc-k); 14044 repeat append_char(buffer[k]); incr(k); 14045 until k=loc; 14046 cur_mod:=make_string; 14047 end; 14048 end; 14049incr(loc); cur_cmd:=string_token; return; 14050end 14051 14052@ We go to |restart| after this error message, not to |switch|, 14053because the |clear_for_error_prompt| routine might have reinstated 14054|token_state| after |error| has finished. 14055 14056@<Decry the missing string delimiter and |goto restart|@>= 14057begin loc:=limit; {the next character to be read on this line will be |"%"|} 14058print_err("Incomplete string token has been flushed"); 14059@.Incomplete string token...@> 14060help3("Strings should finish on the same line as they began.")@/ 14061 ("I've deleted the partial string; you might want to")@/ 14062 ("insert another by typing, e.g., `I""new string""'.");@/ 14063deletions_allowed:=false; error; deletions_allowed:=true; goto restart; 14064end 14065 14066@ @<Get the integer part |n| of a numeric token...@>= 14067n:=c-"0"; 14068while char_class[buffer[loc]]=digit_class do 14069 begin if n<4096 then n:=10*n+buffer[loc]-"0"; 14070 incr(loc); 14071 end; 14072if buffer[loc]="." then if char_class[buffer[loc+1]]=digit_class then goto done; 14073f:=0; goto fin_numeric_token; 14074done: incr(loc) 14075 14076@ @<Get the fraction part |f| of a numeric token@>= 14077k:=0; 14078repeat if k<17 then {digits for |k>=17| cannot affect the result} 14079 begin dig[k]:=buffer[loc]-"0"; incr(k); 14080 end; 14081incr(loc); 14082until char_class[buffer[loc]]<>digit_class; 14083f:=round_decimals(k); 14084if f=unity then 14085 begin incr(n); f:=0; 14086 end 14087 14088@ @<Pack the numeric and fraction parts of a numeric token and |return|@>= 14089if n<4096 then cur_mod:=n*unity+f 14090else begin print_err("Enormous number has been reduced"); 14091@.Enormous number...@> 14092 help2("I can't handle numbers bigger than about 4095.99998;")@/ 14093 ("so I've changed your constant to that maximum amount.");@/ 14094 deletions_allowed:=false; error; deletions_allowed:=true; 14095 cur_mod:=@'1777777777; 14096 end; 14097cur_cmd:=numeric_token; return 14098 14099@ Let's consider now what happens when |get_next| is looking at a token list. 14100@^inner loop@> 14101 14102@<Input from token list;...@>= 14103if loc>=hi_mem_min then {one-word token} 14104 begin cur_sym:=info(loc); loc:=link(loc); {move to next} 14105 if cur_sym>=expr_base then 14106 if cur_sym>=suffix_base then 14107 @<Insert a suffix or text parameter and |goto restart|@> 14108 else begin cur_cmd:=capsule_token; 14109 cur_mod:=param_stack[param_start+cur_sym-(expr_base)]; 14110 cur_sym:=0; return; 14111 end; 14112 end 14113else if loc>null then 14114 @<Get a stored numeric or string or capsule token and |return|@> 14115else begin {we are done with this token list} 14116 end_token_list; goto restart; {resume previous level} 14117 end 14118 14119@ @<Insert a suffix or text parameter...@>= 14120begin if cur_sym>=text_base then cur_sym:=cur_sym-param_size; 14121 {|param_size=text_base-suffix_base|} 14122begin_token_list(param_stack[param_start+cur_sym-(suffix_base)],parameter); 14123goto restart; 14124end 14125 14126@ @<Get a stored numeric or string or capsule token...@>= 14127begin if name_type(loc)=token then 14128 begin cur_mod:=value(loc); 14129 if type(loc)=known then cur_cmd:=numeric_token 14130 else begin cur_cmd:=string_token; add_str_ref(cur_mod); 14131 end; 14132 end 14133else begin cur_mod:=loc; cur_cmd:=capsule_token; 14134 end; 14135loc:=link(loc); return; 14136end 14137 14138@ All of the easy branches of |get_next| have now been taken care of. 14139There is one more branch. 14140 14141@<Move to next line of file, or |goto restart|...@>= 14142if name>2 then @<Read next line of file into |buffer|, or 14143 |goto restart| if the file has ended@> 14144else begin if input_ptr>0 then 14145 {text was inserted during error recovery or by \&{scantokens}} 14146 begin end_file_reading; goto restart; {resume previous level} 14147 end; 14148 if selector<log_only then open_log_file; 14149 if interaction>nonstop_mode then 14150 begin if limit=start then {previous line was empty} 14151 print_nl("(Please type a command or say `end')"); 14152@.Please type...@> 14153 print_ln; first:=start; 14154 prompt_input("*"); {input on-line into |buffer|} 14155@.*\relax@> 14156 limit:=last; buffer[limit]:="%"; 14157 first:=limit+1; loc:=start; 14158 end 14159 else fatal_error("*** (job aborted, no legal end found)"); 14160@.job aborted@> 14161 {nonstop mode, which is intended for overnight batch processing, 14162 never waits for on-line input} 14163 end 14164 14165@ The global variable |force_eof| is normally |false|; it is set |true| 14166by an \&{endinput} command. 14167 14168@<Glob...@>= 14169@!force_eof:boolean; {should the next \&{input} be aborted early?} 14170 14171@ @<Read next line of file into |buffer|, or 14172 |goto restart| if the file has ended@>= 14173begin incr(line); first:=start; 14174if not force_eof then 14175 begin if input_ln(cur_file,true) then {not end of file} 14176 firm_up_the_line {this sets |limit|} 14177 else force_eof:=true; 14178 end; 14179if force_eof then 14180 begin print_char(")"); decr(open_parens); 14181 update_terminal; {show user that file has been read} 14182 force_eof:=false; 14183 end_file_reading; {resume previous level} 14184 if check_outer_validity then goto restart@+else goto restart; 14185 end; 14186buffer[limit]:="%"; first:=limit+1; loc:=start; {ready to read} 14187end 14188 14189@ If the user has set the |pausing| parameter to some positive value, 14190and if nonstop mode has not been selected, each line of input is displayed 14191on the terminal and the transcript file, followed by `\.{=>}'. 14192\MF\ waits for a response. If the response is null (i.e., if nothing is 14193typed except perhaps a few blank spaces), the original 14194line is accepted as it stands; otherwise the line typed is 14195used instead of the line in the file. 14196 14197@p procedure firm_up_the_line; 14198var @!k:0..buf_size; {an index into |buffer|} 14199begin limit:=last; 14200if internal[pausing]>0 then if interaction>nonstop_mode then 14201 begin wake_up_terminal; print_ln; 14202 if start<limit then for k:=start to limit-1 do print(buffer[k]); 14203 first:=limit; prompt_input("=>"); {wait for user response} 14204@.=>@> 14205 if last>first then 14206 begin for k:=first to last-1 do {move line down in buffer} 14207 buffer[k+start-first]:=buffer[k]; 14208 limit:=start+last-first; 14209 end; 14210 end; 14211end; 14212 14213@* \[34] Scanning macro definitions. 14214\MF\ has a variety of ways to tuck tokens away into token lists for later 14215use: Macros can be defined with \&{def}, \&{vardef}, \&{primarydef}, etc.; 14216repeatable code can be defined with \&{for}, \&{forever}, \&{forsuffixes}. 14217All such operations are handled by the routines in this part of the program. 14218 14219The modifier part of each command code is zero for the ``ending delimiters'' 14220like \&{enddef} and \&{endfor}. 14221 14222@d start_def=1 {command modifier for \&{def}} 14223@d var_def=2 {command modifier for \&{vardef}} 14224@d end_def=0 {command modifier for \&{enddef}} 14225@d start_forever=1 {command modifier for \&{forever}} 14226@d end_for=0 {command modifier for \&{endfor}} 14227 14228@<Put each...@>= 14229primitive("def",macro_def,start_def);@/ 14230@!@:def_}{\&{def} primitive@> 14231primitive("vardef",macro_def,var_def);@/ 14232@!@:var_def_}{\&{vardef} primitive@> 14233primitive("primarydef",macro_def,secondary_primary_macro);@/ 14234@!@:primary_def_}{\&{primarydef} primitive@> 14235primitive("secondarydef",macro_def,tertiary_secondary_macro);@/ 14236@!@:secondary_def_}{\&{secondarydef} primitive@> 14237primitive("tertiarydef",macro_def,expression_tertiary_macro);@/ 14238@!@:tertiary_def_}{\&{tertiarydef} primitive@> 14239primitive("enddef",macro_def,end_def); eqtb[frozen_end_def]:=eqtb[cur_sym];@/ 14240@!@:end_def_}{\&{enddef} primitive@> 14241@# 14242primitive("for",iteration,expr_base);@/ 14243@!@:for_}{\&{for} primitive@> 14244primitive("forsuffixes",iteration,suffix_base);@/ 14245@!@:for_suffixes_}{\&{forsuffixes} primitive@> 14246primitive("forever",iteration,start_forever);@/ 14247@!@:forever_}{\&{forever} primitive@> 14248primitive("endfor",iteration,end_for); eqtb[frozen_end_for]:=eqtb[cur_sym];@/ 14249@!@:end_for_}{\&{endfor} primitive@> 14250 14251@ @<Cases of |print_cmd...@>= 14252macro_def:if m<=var_def then 14253 if m=start_def then print("def") 14254 else if m<start_def then print("enddef") 14255 else print("vardef") 14256 else if m=secondary_primary_macro then print("primarydef") 14257 else if m=tertiary_secondary_macro then print("secondarydef") 14258 else print("tertiarydef"); 14259iteration: if m<=start_forever then 14260 if m=start_forever then print("forever")@+else print("endfor") 14261 else if m=expr_base then print("for")@+else print("forsuffixes"); 14262 14263@ Different macro-absorbing operations have different syntaxes, but they 14264also have a lot in common. There is a list of special symbols that are to 14265be replaced by parameter tokens; there is a special command code that 14266ends the definition; the quotation conventions are identical. Therefore 14267it makes sense to have most of the work done by a single subroutine. That 14268subroutine is called |scan_toks|. 14269 14270The first parameter to |scan_toks| is the command code that will 14271terminate scanning (either |macro_def| or |iteration|). 14272 14273The second parameter, |subst_list|, points to a (possibly empty) list 14274of two-word nodes whose |info| and |value| fields specify symbol tokens 14275before and after replacement. The list will be returned to free storage 14276by |scan_toks|. 14277 14278The third parameter is simply appended to the token list that is built. 14279And the final parameter tells how many of the special operations 14280\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#} are to be replaced by suffix parameters. 14281When such parameters are present, they are called \.{(SUFFIX0)}, 14282\.{(SUFFIX1)}, and \.{(SUFFIX2)}. 14283 14284@p function scan_toks(@!terminator:command_code; 14285 @!subst_list,@!tail_end:pointer;@!suffix_count:small_number):pointer; 14286label done,found; 14287var @!p:pointer; {tail of the token list being built} 14288@!q:pointer; {temporary for link management} 14289@!balance:integer; {left delimiters minus right delimiters} 14290begin p:=hold_head; balance:=1; link(hold_head):=null; 14291loop@+ begin get_next; 14292 if cur_sym>0 then 14293 begin @<Substitute for |cur_sym|, if it's on the |subst_list|@>; 14294 if cur_cmd=terminator then 14295 @<Adjust the balance; |goto done| if it's zero@> 14296 else if cur_cmd=macro_special then 14297 @<Handle quoted symbols, \.{\#\AT!}, \.{\AT!}, or \.{\AT!\#}@>; 14298 end; 14299 link(p):=cur_tok; p:=link(p); 14300 end; 14301done: link(p):=tail_end; flush_node_list(subst_list); 14302scan_toks:=link(hold_head); 14303end; 14304 14305@ @<Substitute for |cur_sym|...@>= 14306begin q:=subst_list; 14307while q<>null do 14308 begin if info(q)=cur_sym then 14309 begin cur_sym:=value(q); cur_cmd:=relax; goto found; 14310 end; 14311 q:=link(q); 14312 end; 14313found:end 14314 14315@ @<Adjust the balance; |goto done| if it's zero@>= 14316if cur_mod>0 then incr(balance) 14317else begin decr(balance); 14318 if balance=0 then goto done; 14319 end 14320 14321@ Four commands are intended to be used only within macro texts: \&{quote}, 14322\.{\#\AT!}, \.{\AT!}, and \.{\AT!\#}. They are variants of a single command 14323code called |macro_special|. 14324 14325@d quote=0 {|macro_special| modifier for \&{quote}} 14326@d macro_prefix=1 {|macro_special| modifier for \.{\#\AT!}} 14327@d macro_at=2 {|macro_special| modifier for \.{\AT!}} 14328@d macro_suffix=3 {|macro_special| modifier for \.{\AT!\#}} 14329 14330@<Put each...@>= 14331primitive("quote",macro_special,quote);@/ 14332@!@:quote_}{\&{quote} primitive@> 14333primitive("#@@",macro_special,macro_prefix);@/ 14334@!@:]]]\#\AT!_}{\.{\#\AT!} primitive@> 14335primitive("@@",macro_special,macro_at);@/ 14336@!@:]]]\AT!_}{\.{\AT!} primitive@> 14337primitive("@@#",macro_special,macro_suffix);@/ 14338@!@:]]]\AT!\#_}{\.{\AT!\#} primitive@> 14339 14340@ @<Cases of |print_cmd...@>= 14341macro_special: case m of 14342 macro_prefix: print("#@@"); 14343 macro_at: print_char("@@"); 14344 macro_suffix: print("@@#"); 14345 othercases print("quote") 14346 endcases; 14347 14348@ @<Handle quoted...@>= 14349begin if cur_mod=quote then get_next 14350else if cur_mod<=suffix_count then cur_sym:=suffix_base-1+cur_mod; 14351end 14352 14353@ Here is a routine that's used whenever a token will be redefined. If 14354the user's token is unredefinable, the `|frozen_inaccessible|' token is 14355substituted; the latter is redefinable but essentially impossible to use, 14356hence \MF's tables won't get fouled up. 14357 14358@p procedure get_symbol; {sets |cur_sym| to a safe symbol} 14359label restart; 14360begin restart: get_next; 14361if (cur_sym=0)or(cur_sym>frozen_inaccessible) then 14362 begin print_err("Missing symbolic token inserted"); 14363@.Missing symbolic token...@> 14364 help3("Sorry: You can't redefine a number, string, or expr.")@/ 14365 ("I've inserted an inaccessible symbol so that your")@/ 14366 ("definition will be completed without mixing me up too badly."); 14367 if cur_sym>0 then 14368 help_line[2]:="Sorry: You can't redefine my error-recovery tokens." 14369 else if cur_cmd=string_token then delete_str_ref(cur_mod); 14370 cur_sym:=frozen_inaccessible; ins_error; goto restart; 14371 end; 14372end; 14373 14374@ Before we actually redefine a symbolic token, we need to clear away its 14375former value, if it was a variable. The following stronger version of 14376|get_symbol| does that. 14377 14378@p procedure get_clear_symbol; 14379begin get_symbol; clear_symbol(cur_sym,false); 14380end; 14381 14382@ Here's another little subroutine; it checks that an equals sign 14383or assignment sign comes along at the proper place in a macro definition. 14384 14385@p procedure check_equals; 14386begin if cur_cmd<>equals then if cur_cmd<>assignment then 14387 begin missing_err("=");@/ 14388@.Missing `='@> 14389 help5("The next thing in this `def' should have been `=',")@/ 14390 ("because I've already looked at the definition heading.")@/ 14391 ("But don't worry; I'll pretend that an equals sign")@/ 14392 ("was present. Everything from here to `enddef'")@/ 14393 ("will be the replacement text of this macro."); 14394 back_error; 14395 end; 14396end; 14397 14398@ A \&{primarydef}, \&{secondarydef}, or \&{tertiarydef} is rather easily 14399handled now that we have |scan_toks|. In this case there are 14400two parameters, which will be \.{EXPR0} and \.{EXPR1} (i.e., 14401|expr_base| and |expr_base+1|). 14402 14403@p procedure make_op_def; 14404var @!m:command_code; {the type of definition} 14405@!p,@!q,@!r:pointer; {for list manipulation} 14406begin m:=cur_mod;@/ 14407get_symbol; q:=get_node(token_node_size); 14408info(q):=cur_sym; value(q):=expr_base;@/ 14409get_clear_symbol; warning_info:=cur_sym;@/ 14410get_symbol; p:=get_node(token_node_size); 14411info(p):=cur_sym; value(p):=expr_base+1; link(p):=q;@/ 14412get_next; check_equals;@/ 14413scanner_status:=op_defining; q:=get_avail; ref_count(q):=null; 14414r:=get_avail; link(q):=r; info(r):=general_macro; 14415link(r):=scan_toks(macro_def,p,null,0); 14416scanner_status:=normal; eq_type(warning_info):=m; 14417equiv(warning_info):=q; get_x_next; 14418end; 14419 14420@ Parameters to macros are introduced by the keywords \&{expr}, 14421\&{suffix}, \&{text}, \&{primary}, \&{secondary}, and \&{tertiary}. 14422 14423@<Put each...@>= 14424primitive("expr",param_type,expr_base);@/ 14425@!@:expr_}{\&{expr} primitive@> 14426primitive("suffix",param_type,suffix_base);@/ 14427@!@:suffix_}{\&{suffix} primitive@> 14428primitive("text",param_type,text_base);@/ 14429@!@:text_}{\&{text} primitive@> 14430primitive("primary",param_type,primary_macro);@/ 14431@!@:primary_}{\&{primary} primitive@> 14432primitive("secondary",param_type,secondary_macro);@/ 14433@!@:secondary_}{\&{secondary} primitive@> 14434primitive("tertiary",param_type,tertiary_macro);@/ 14435@!@:tertiary_}{\&{tertiary} primitive@> 14436 14437@ @<Cases of |print_cmd...@>= 14438param_type:if m>=expr_base then 14439 if m=expr_base then print("expr") 14440 else if m=suffix_base then print("suffix") 14441 else print("text") 14442 else if m<secondary_macro then print("primary") 14443 else if m=secondary_macro then print("secondary") 14444 else print("tertiary"); 14445 14446@ Let's turn next to the more complex processing associated with \&{def} 14447and \&{vardef}. When the following procedure is called, |cur_mod| 14448should be either |start_def| or |var_def|. 14449 14450@p @t\4@>@<Declare the procedure called |check_delimiter|@>@; 14451@t\4@>@<Declare the function called |scan_declared_variable|@>@; 14452procedure scan_def; 14453var @!m:start_def..var_def; {the type of definition} 14454@!n:0..3; {the number of special suffix parameters} 14455@!k:0..param_size; {the total number of parameters} 14456@!c:general_macro..text_macro; {the kind of macro we're defining} 14457@!r:pointer; {parameter-substitution list} 14458@!q:pointer; {tail of the macro token list} 14459@!p:pointer; {temporary storage} 14460@!base:halfword; {|expr_base|, |suffix_base|, or |text_base|} 14461@!l_delim,@!r_delim:pointer; {matching delimiters} 14462begin m:=cur_mod; c:=general_macro; link(hold_head):=null;@/ 14463q:=get_avail; ref_count(q):=null; r:=null;@/ 14464@<Scan the token or variable to be defined; 14465 set |n|, |scanner_status|, and |warning_info|@>; 14466k:=n; 14467if cur_cmd=left_delimiter then 14468 @<Absorb delimited parameters, putting them into lists |q| and |r|@>; 14469if cur_cmd=param_type then 14470 @<Absorb undelimited parameters, putting them into list |r|@>; 14471check_equals; 14472p:=get_avail; info(p):=c; link(q):=p; 14473@<Attach the replacement text to the tail of node |p|@>; 14474scanner_status:=normal; get_x_next; 14475end; 14476 14477@ We don't put `|frozen_end_group|' into the replacement text of 14478a \&{vardef}, because the user may want to redefine `\.{endgroup}'. 14479 14480@<Attach the replacement text to the tail of node |p|@>= 14481if m=start_def then link(p):=scan_toks(macro_def,r,null,n) 14482else begin q:=get_avail; info(q):=bg_loc; link(p):=q; 14483 p:=get_avail; info(p):=eg_loc; 14484 link(q):=scan_toks(macro_def,r,p,n); 14485 end; 14486if warning_info=bad_vardef then flush_token_list(value(bad_vardef)) 14487 14488@ @<Glob...@>= 14489@!bg_loc,@!eg_loc:1..hash_end; 14490 {hash addresses of `\.{begingroup}' and `\.{endgroup}'} 14491 14492@ @<Scan the token or variable to be defined;...@>= 14493if m=start_def then 14494 begin get_clear_symbol; warning_info:=cur_sym; get_next; 14495 scanner_status:=op_defining; n:=0; 14496 eq_type(warning_info):=defined_macro; equiv(warning_info):=q; 14497 end 14498else begin p:=scan_declared_variable; 14499 flush_variable(equiv(info(p)),link(p),true); 14500 warning_info:=find_variable(p); flush_list(p); 14501 if warning_info=null then @<Change to `\.{a bad variable}'@>; 14502 scanner_status:=var_defining; n:=2; 14503 if cur_cmd=macro_special then if cur_mod=macro_suffix then {\.{\AT!\#}} 14504 begin n:=3; get_next; 14505 end; 14506 type(warning_info):=unsuffixed_macro-2+n; value(warning_info):=q; 14507 end {|suffixed_macro=unsuffixed_macro+1|} 14508 14509@ @<Change to `\.{a bad variable}'@>= 14510begin print_err("This variable already starts with a macro"); 14511@.This variable already...@> 14512help2("After `vardef a' you can't say `vardef a.b'.")@/ 14513 ("So I'll have to discard this definition."); 14514error; warning_info:=bad_vardef; 14515end 14516 14517@ @<Initialize table entries...@>= 14518name_type(bad_vardef):=root; link(bad_vardef):=frozen_bad_vardef; 14519equiv(frozen_bad_vardef):=bad_vardef; eq_type(frozen_bad_vardef):=tag_token; 14520 14521@ @<Absorb delimited parameters, putting them into lists |q| and |r|@>= 14522repeat l_delim:=cur_sym; r_delim:=cur_mod; get_next; 14523if (cur_cmd=param_type)and(cur_mod>=expr_base) then base:=cur_mod 14524else begin print_err("Missing parameter type; `expr' will be assumed"); 14525@.Missing parameter type@> 14526 help1("You should've had `expr' or `suffix' or `text' here."); 14527 back_error; base:=expr_base; 14528 end; 14529@<Absorb parameter tokens for type |base|@>; 14530check_delimiter(l_delim,r_delim); 14531get_next; 14532until cur_cmd<>left_delimiter 14533 14534@ @<Absorb parameter tokens for type |base|@>= 14535repeat link(q):=get_avail; q:=link(q); info(q):=base+k;@/ 14536get_symbol; p:=get_node(token_node_size); value(p):=base+k; info(p):=cur_sym; 14537if k=param_size then overflow("parameter stack size",param_size); 14538@:METAFONT capacity exceeded parameter stack size}{\quad parameter stack size@> 14539incr(k); link(p):=r; r:=p; get_next; 14540until cur_cmd<>comma 14541 14542@ @<Absorb undelimited parameters, putting them into list |r|@>= 14543begin p:=get_node(token_node_size); 14544if cur_mod<expr_base then 14545 begin c:=cur_mod; value(p):=expr_base+k; 14546 end 14547else begin value(p):=cur_mod+k; 14548 if cur_mod=expr_base then c:=expr_macro 14549 else if cur_mod=suffix_base then c:=suffix_macro 14550 else c:=text_macro; 14551 end; 14552if k=param_size then overflow("parameter stack size",param_size); 14553incr(k); get_symbol; info(p):=cur_sym; link(p):=r; r:=p; get_next; 14554if c=expr_macro then if cur_cmd=of_token then 14555 begin c:=of_macro; p:=get_node(token_node_size); 14556 if k=param_size then overflow("parameter stack size",param_size); 14557 value(p):=expr_base+k; get_symbol; info(p):=cur_sym; 14558 link(p):=r; r:=p; get_next; 14559 end; 14560end 14561 14562@* \[35] Expanding the next token. 14563Only a few command codes |<min_command| can possibly be returned by 14564|get_next|; in increasing order, they are 14565|if_test|, |fi_or_else|, |input|, |iteration|, |repeat_loop|, 14566|exit_test|, |relax|, |scan_tokens|, |expand_after|, and |defined_macro|. 14567 14568\MF\ usually gets the next token of input by saying |get_x_next|. This is 14569like |get_next| except that it keeps getting more tokens until 14570finding |cur_cmd>=min_command|. In other words, |get_x_next| expands 14571macros and removes conditionals or iterations or input instructions that 14572might be present. 14573 14574It follows that |get_x_next| might invoke itself recursively. In fact, 14575there is massive recursion, since macro expansion can involve the 14576scanning of arbitrarily complex expressions, which in turn involve 14577macro expansion and conditionals, etc. 14578@^recursion@> 14579 14580Therefore it's necessary to declare a whole bunch of |forward| 14581procedures at this point, and to insert some other procedures 14582that will be invoked by |get_x_next|. 14583 14584@p procedure@?scan_primary; forward;@t\2@> 14585procedure@?scan_secondary; forward;@t\2@> 14586procedure@?scan_tertiary; forward;@t\2@> 14587procedure@?scan_expression; forward;@t\2@> 14588procedure@?scan_suffix; forward;@t\2@>@/ 14589@t\4@>@<Declare the procedure called |macro_call|@>@;@/ 14590procedure@?get_boolean; forward;@t\2@> 14591procedure@?pass_text; forward;@t\2@> 14592procedure@?conditional; forward;@t\2@> 14593procedure@?start_input; forward;@t\2@> 14594procedure@?begin_iteration; forward;@t\2@> 14595procedure@?resume_iteration; forward;@t\2@> 14596procedure@?stop_iteration; forward;@t\2@> 14597 14598@ An auxiliary subroutine called |expand| is used by |get_x_next| 14599when it has to do exotic expansion commands. 14600 14601@p procedure expand; 14602var @!p:pointer; {for list manipulation} 14603@!k:integer; {something that we hope is |<=buf_size|} 14604@!j:pool_pointer; {index into |str_pool|} 14605begin if internal[tracing_commands]>unity then if cur_cmd<>defined_macro then 14606 show_cur_cmd_mod; 14607case cur_cmd of 14608if_test:conditional; {this procedure is discussed in Part 36 below} 14609fi_or_else:@<Terminate the current conditional and skip to \&{fi}@>; 14610input:@<Initiate or terminate input from a file@>; 14611iteration:if cur_mod=end_for then 14612 @<Scold the user for having an extra \&{endfor}@> 14613 else begin_iteration; {this procedure is discussed in Part 37 below} 14614repeat_loop: @<Repeat a loop@>; 14615exit_test: @<Exit a loop if the proper time has come@>; 14616relax: do_nothing; 14617expand_after: @<Expand the token after the next token@>; 14618scan_tokens: @<Put a string into the input buffer@>; 14619defined_macro:macro_call(cur_mod,null,cur_sym); 14620end; {there are no other cases} 14621end; 14622 14623@ @<Scold the user...@>= 14624begin print_err("Extra `endfor'"); 14625@.Extra `endfor'@> 14626help2("I'm not currently working on a for loop,")@/ 14627 ("so I had better not try to end anything.");@/ 14628error; 14629end 14630 14631@ The processing of \&{input} involves the |start_input| subroutine, 14632which will be declared later; the processing of \&{endinput} is trivial. 14633 14634@<Put each...@>= 14635primitive("input",input,0);@/ 14636@!@:input_}{\&{input} primitive@> 14637primitive("endinput",input,1);@/ 14638@!@:end_input_}{\&{endinput} primitive@> 14639 14640@ @<Cases of |print_cmd_mod|...@>= 14641input: if m=0 then print("input")@+else print("endinput"); 14642 14643@ @<Initiate or terminate input...@>= 14644if cur_mod>0 then force_eof:=true 14645else start_input 14646 14647@ We'll discuss the complicated parts of loop operations later. For now 14648it suffices to know that there's a global variable called |loop_ptr| 14649that will be |null| if no loop is in progress. 14650 14651@<Repeat a loop@>= 14652begin while token_state and(loc=null) do end_token_list; {conserve stack space} 14653if loop_ptr=null then 14654 begin print_err("Lost loop"); 14655@.Lost loop@> 14656 help2("I'm confused; after exiting from a loop, I still seem")@/ 14657 ("to want to repeat it. I'll try to forget the problem.");@/ 14658 error; 14659 end 14660else resume_iteration; {this procedure is in Part 37 below} 14661end 14662 14663@ @<Exit a loop if the proper time has come@>= 14664begin get_boolean; 14665if internal[tracing_commands]>unity then show_cmd_mod(nullary,cur_exp); 14666if cur_exp=true_code then 14667 if loop_ptr=null then 14668 begin print_err("No loop is in progress"); 14669@.No loop is in progress@> 14670 help1("Why say `exitif' when there's nothing to exit from?"); 14671 if cur_cmd=semicolon then error@+else back_error; 14672 end 14673 else @<Exit prematurely from an iteration@> 14674else if cur_cmd<>semicolon then 14675 begin missing_err(";");@/ 14676@.Missing `;'@> 14677 help2("After `exitif <boolean exp>' I expect to see a semicolon.")@/ 14678 ("I shall pretend that one was there."); back_error; 14679 end; 14680end 14681 14682@ Here we use the fact that |forever_text| is the only |token_type| that 14683is less than |loop_text|. 14684 14685@<Exit prematurely...@>= 14686begin p:=null; 14687repeat if file_state then end_file_reading 14688else begin if token_type<=loop_text then p:=start; 14689 end_token_list; 14690 end; 14691until p<>null; 14692if p<>info(loop_ptr) then fatal_error("*** (loop confusion)"); 14693@.loop confusion@> 14694stop_iteration; {this procedure is in Part 37 below} 14695end 14696 14697@ @<Expand the token after the next token@>= 14698begin get_next; 14699p:=cur_tok; get_next; 14700if cur_cmd<min_command then expand else back_input; 14701back_list(p); 14702end 14703 14704@ @<Put a string into the input buffer@>= 14705begin get_x_next; scan_primary; 14706if cur_type<>string_type then 14707 begin disp_err(null,"Not a string"); 14708@.Not a string@> 14709 help2("I'm going to flush this expression, since")@/ 14710 ("scantokens should be followed by a known string."); 14711 put_get_flush_error(0); 14712 end 14713else begin back_input; 14714 if length(cur_exp)>0 then @<Pretend we're reading a new one-line file@>; 14715 end; 14716end 14717 14718@ @<Pretend we're reading a new one-line file@>= 14719begin begin_file_reading; name:=2; 14720k:=first+length(cur_exp); 14721if k>=max_buf_stack then 14722 begin if k>=buf_size then 14723 begin max_buf_stack:=buf_size; 14724 overflow("buffer size",buf_size); 14725@:METAFONT capacity exceeded buffer size}{\quad buffer size@> 14726 end; 14727 max_buf_stack:=k+1; 14728 end; 14729j:=str_start[cur_exp]; limit:=k; 14730while first<limit do 14731 begin buffer[first]:=so(str_pool[j]); incr(j); incr(first); 14732 end; 14733buffer[limit]:="%"; first:=limit+1; loc:=start; flush_cur_exp(0); 14734end 14735 14736@ Here finally is |get_x_next|. 14737 14738The expression scanning routines to be considered later 14739communicate via the global quantities |cur_type| and |cur_exp|; 14740we must be very careful to save and restore these quantities while 14741macros are being expanded. 14742@^inner loop@> 14743 14744@p procedure get_x_next; 14745var @!save_exp:pointer; {a capsule to save |cur_type| and |cur_exp|} 14746begin get_next; 14747if cur_cmd<min_command then 14748 begin save_exp:=stash_cur_exp; 14749 repeat if cur_cmd=defined_macro then macro_call(cur_mod,null,cur_sym) 14750 else expand; 14751 get_next; 14752 until cur_cmd>=min_command; 14753 unstash_cur_exp(save_exp); {that restores |cur_type| and |cur_exp|} 14754 end; 14755end; 14756 14757@ Now let's consider the |macro_call| procedure, which is used to start up 14758all user-defined macros. Since the arguments to a macro might be expressions, 14759|macro_call| is recursive. 14760@^recursion@> 14761 14762The first parameter to |macro_call| points to the reference count of the 14763token list that defines the macro. The second parameter contains any 14764arguments that have already been parsed (see below). The third parameter 14765points to the symbolic token that names the macro. If the third parameter 14766is |null|, the macro was defined by \&{vardef}, so its name can be 14767reconstructed from the prefix and ``at'' arguments found within the 14768second parameter. 14769 14770What is this second parameter? It's simply a linked list of one-word items, 14771whose |info| fields point to the arguments. In other words, if |arg_list=null|, 14772no arguments have been scanned yet; otherwise |info(arg_list)| points to 14773the first scanned argument, and |link(arg_list)| points to the list of 14774further arguments (if any). 14775 14776Arguments of type \&{expr} are so-called capsules, which we will 14777discuss later when we concentrate on expressions; they can be 14778recognized easily because their |link| field is |void|. Arguments of type 14779\&{suffix} and \&{text} are token lists without reference counts. 14780 14781@ After argument scanning is complete, the arguments are moved to the 14782|param_stack|. (They can't be put on that stack any sooner, because 14783the stack is growing and shrinking in unpredictable ways as more arguments 14784are being acquired.) Then the macro body is fed to the scanner; i.e., 14785the replacement text of the macro is placed at the top of the \MF's 14786input stack, so that |get_next| will proceed to read it next. 14787 14788@<Declare the procedure called |macro_call|@>= 14789@t\4@>@<Declare the procedure called |print_macro_name|@>@; 14790@t\4@>@<Declare the procedure called |print_arg|@>@; 14791@t\4@>@<Declare the procedure called |scan_text_arg|@>@; 14792procedure macro_call(@!def_ref,@!arg_list,@!macro_name:pointer); 14793 {invokes a user-defined control sequence} 14794label found; 14795var @!r:pointer; {current node in the macro's token list} 14796@!p,@!q:pointer; {for list manipulation} 14797@!n:integer; {the number of arguments} 14798@!l_delim,@!r_delim:pointer; {a delimiter pair} 14799@!tail:pointer; {tail of the argument list} 14800begin r:=link(def_ref); add_mac_ref(def_ref); 14801if arg_list=null then n:=0 14802else @<Determine the number |n| of arguments already supplied, 14803 and set |tail| to the tail of |arg_list|@>; 14804if internal[tracing_macros]>0 then 14805 @<Show the text of the macro being expanded, and the existing arguments@>; 14806@<Scan the remaining arguments, if any; set |r| to the first token 14807 of the replacement text@>; 14808@<Feed the arguments and replacement text to the scanner@>; 14809end; 14810 14811@ @<Show the text of the macro...@>= 14812begin begin_diagnostic; print_ln; print_macro_name(arg_list,macro_name); 14813if n=3 then print("@@#"); {indicate a suffixed macro} 14814show_macro(def_ref,null,100000); 14815if arg_list<>null then 14816 begin n:=0; p:=arg_list; 14817 repeat q:=info(p); 14818 print_arg(q,n,0); 14819 incr(n); p:=link(p); 14820 until p=null; 14821 end; 14822end_diagnostic(false); 14823end 14824 14825@ @<Declare the procedure called |print_macro_name|@>= 14826procedure print_macro_name(@!a,@!n:pointer); 14827var @!p,@!q:pointer; {they traverse the first part of |a|} 14828begin if n<>null then slow_print(text(n)) 14829else begin p:=info(a); 14830 if p=null then slow_print(text(info(info(link(a))))) 14831 else begin q:=p; 14832 while link(q)<>null do q:=link(q); 14833 link(q):=info(link(a)); 14834 show_token_list(p,null,1000,0); 14835 link(q):=null; 14836 end; 14837 end; 14838end; 14839 14840@ @<Declare the procedure called |print_arg|@>= 14841procedure print_arg(@!q:pointer;@!n:integer;@!b:pointer); 14842begin if link(q)=void then print_nl("(EXPR") 14843else if (b<text_base)and(b<>text_macro) then print_nl("(SUFFIX") 14844else print_nl("(TEXT"); 14845print_int(n); print(")<-"); 14846if link(q)=void then print_exp(q,1) 14847else show_token_list(q,null,1000,0); 14848end; 14849 14850@ @<Determine the number |n| of arguments already supplied...@>= 14851begin n:=1; tail:=arg_list; 14852while link(tail)<>null do 14853 begin incr(n); tail:=link(tail); 14854 end; 14855end 14856 14857@ @<Scan the remaining arguments, if any; set |r|...@>= 14858cur_cmd:=comma+1; {anything |<>comma| will do} 14859while info(r)>=expr_base do 14860 begin @<Scan the delimited argument represented by |info(r)|@>; 14861 r:=link(r); 14862 end; 14863if cur_cmd=comma then 14864 begin print_err("Too many arguments to "); 14865@.Too many arguments...@> 14866 print_macro_name(arg_list,macro_name); print_char(";"); 14867 print_nl(" Missing `"); slow_print(text(r_delim)); 14868@.Missing `)'...@> 14869 print("' has been inserted"); 14870 help3("I'm going to assume that the comma I just read was a")@/ 14871 ("right delimiter, and then I'll begin expanding the macro.")@/ 14872 ("You might want to delete some tokens before continuing."); 14873 error; 14874 end; 14875if info(r)<>general_macro then @<Scan undelimited argument(s)@>; 14876r:=link(r) 14877 14878@ At this point, the reader will find it advisable to review the explanation 14879of token list format that was presented earlier, paying special attention to 14880the conventions that apply only at the beginning of a macro's token list. 14881 14882On the other hand, the reader will have to take the expression-parsing 14883aspects of the following program on faith; we will explain |cur_type| 14884and |cur_exp| later. (Several things in this program depend on each other, 14885and it's necessary to jump into the circle somewhere.) 14886 14887@<Scan the delimited argument represented by |info(r)|@>= 14888if cur_cmd<>comma then 14889 begin get_x_next; 14890 if cur_cmd<>left_delimiter then 14891 begin print_err("Missing argument to "); 14892@.Missing argument...@> 14893 print_macro_name(arg_list,macro_name); 14894 help3("That macro has more parameters than you thought.")@/ 14895 ("I'll continue by pretending that each missing argument")@/ 14896 ("is either zero or null."); 14897 if info(r)>=suffix_base then 14898 begin cur_exp:=null; cur_type:=token_list; 14899 end 14900 else begin cur_exp:=0; cur_type:=known; 14901 end; 14902 back_error; cur_cmd:=right_delimiter; goto found; 14903 end; 14904 l_delim:=cur_sym; r_delim:=cur_mod; 14905 end; 14906@<Scan the argument represented by |info(r)|@>; 14907if cur_cmd<>comma then @<Check that the proper right delimiter was present@>; 14908found: @<Append the current expression to |arg_list|@> 14909 14910@ @<Check that the proper right delim...@>= 14911if (cur_cmd<>right_delimiter)or(cur_mod<>l_delim) then 14912 if info(link(r))>=expr_base then 14913 begin missing_err(","); 14914@.Missing `,'@> 14915 help3("I've finished reading a macro argument and am about to")@/ 14916 ("read another; the arguments weren't delimited correctly.")@/ 14917 ("You might want to delete some tokens before continuing."); 14918 back_error; cur_cmd:=comma; 14919 end 14920 else begin missing_err(text(r_delim)); 14921@.Missing `)'@> 14922 help2("I've gotten to the end of the macro parameter list.")@/ 14923 ("You might want to delete some tokens before continuing."); 14924 back_error; 14925 end 14926 14927@ A \&{suffix} or \&{text} parameter will have been scanned as 14928a token list pointed to by |cur_exp|, in which case we will have 14929|cur_type=token_list|. 14930 14931@<Append the current expression to |arg_list|@>= 14932begin p:=get_avail; 14933if cur_type=token_list then info(p):=cur_exp 14934else info(p):=stash_cur_exp; 14935if internal[tracing_macros]>0 then 14936 begin begin_diagnostic; print_arg(info(p),n,info(r)); end_diagnostic(false); 14937 end; 14938if arg_list=null then arg_list:=p 14939else link(tail):=p; 14940tail:=p; incr(n); 14941end 14942 14943@ @<Scan the argument represented by |info(r)|@>= 14944if info(r)>=text_base then scan_text_arg(l_delim,r_delim) 14945else begin get_x_next; 14946 if info(r)>=suffix_base then scan_suffix 14947 else scan_expression; 14948 end 14949 14950@ The parameters to |scan_text_arg| are either a pair of delimiters 14951or zero; the latter case is for undelimited text arguments, which 14952end with the first semicolon or \&{endgroup} or \&{end} that is not 14953contained in a group. 14954 14955@<Declare the procedure called |scan_text_arg|@>= 14956procedure scan_text_arg(@!l_delim,@!r_delim:pointer); 14957label done; 14958var @!balance:integer; {excess of |l_delim| over |r_delim|} 14959@!p:pointer; {list tail} 14960begin warning_info:=l_delim; scanner_status:=absorbing; 14961p:=hold_head; balance:=1; link(hold_head):=null; 14962loop@+ begin get_next; 14963 if l_delim=0 then @<Adjust the balance for an undelimited argument; 14964 |goto done| if done@> 14965 else @<Adjust the balance for a delimited argument; 14966 |goto done| if done@>; 14967 link(p):=cur_tok; p:=link(p); 14968 end; 14969done: cur_exp:=link(hold_head); cur_type:=token_list; 14970scanner_status:=normal; 14971end; 14972 14973@ @<Adjust the balance for a delimited argument...@>= 14974begin if cur_cmd=right_delimiter then 14975 begin if cur_mod=l_delim then 14976 begin decr(balance); 14977 if balance=0 then goto done; 14978 end; 14979 end 14980else if cur_cmd=left_delimiter then if cur_mod=r_delim then incr(balance); 14981end 14982 14983@ @<Adjust the balance for an undelimited...@>= 14984begin if end_of_statement then {|cur_cmd=semicolon|, |end_group|, or |stop|} 14985 begin if balance=1 then goto done 14986 else if cur_cmd=end_group then decr(balance); 14987 end 14988else if cur_cmd=begin_group then incr(balance); 14989end 14990 14991@ @<Scan undelimited argument(s)@>= 14992begin if info(r)<text_macro then 14993 begin get_x_next; 14994 if info(r)<>suffix_macro then 14995 if (cur_cmd=equals)or(cur_cmd=assignment) then get_x_next; 14996 end; 14997case info(r) of 14998primary_macro:scan_primary; 14999secondary_macro:scan_secondary; 15000tertiary_macro:scan_tertiary; 15001expr_macro:scan_expression; 15002of_macro:@<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>; 15003suffix_macro:@<Scan a suffix with optional delimiters@>; 15004text_macro:scan_text_arg(0,0); 15005end; {there are no other cases} 15006back_input; @<Append the current expression to |arg_list|@>; 15007end 15008 15009@ @<Scan an expression followed by `\&{of} $\langle$primary$\rangle$'@>= 15010begin scan_expression; p:=get_avail; info(p):=stash_cur_exp; 15011if internal[tracing_macros]>0 then 15012 begin begin_diagnostic; print_arg(info(p),n,0); end_diagnostic(false); 15013 end; 15014if arg_list=null then arg_list:=p@+else link(tail):=p; 15015tail:=p;incr(n); 15016if cur_cmd<>of_token then 15017 begin missing_err("of"); print(" for "); 15018@.Missing `of'@> 15019 print_macro_name(arg_list,macro_name); 15020 help1("I've got the first argument; will look now for the other."); 15021 back_error; 15022 end; 15023get_x_next; scan_primary; 15024end 15025 15026@ @<Scan a suffix with optional delimiters@>= 15027begin if cur_cmd<>left_delimiter then l_delim:=null 15028else begin l_delim:=cur_sym; r_delim:=cur_mod; get_x_next; 15029 end; 15030scan_suffix; 15031if l_delim<>null then 15032 begin if(cur_cmd<>right_delimiter)or(cur_mod<>l_delim) then 15033 begin missing_err(text(r_delim)); 15034@.Missing `)'@> 15035 help2("I've gotten to the end of the macro parameter list.")@/ 15036 ("You might want to delete some tokens before continuing."); 15037 back_error; 15038 end; 15039 get_x_next; 15040 end; 15041end 15042 15043@ Before we put a new token list on the input stack, it is wise to clean off 15044all token lists that have recently been depleted. Then a user macro that ends 15045with a call to itself will not require unbounded stack space. 15046 15047@<Feed the arguments and replacement text to the scanner@>= 15048while token_state and(loc=null) do end_token_list; {conserve stack space} 15049if param_ptr+n>max_param_stack then 15050 begin max_param_stack:=param_ptr+n; 15051 if max_param_stack>param_size then 15052 overflow("parameter stack size",param_size); 15053@:METAFONT capacity exceeded parameter stack size}{\quad parameter stack size@> 15054 end; 15055begin_token_list(def_ref,macro); name:=macro_name; loc:=r; 15056if n>0 then 15057 begin p:=arg_list; 15058 repeat param_stack[param_ptr]:=info(p); incr(param_ptr); p:=link(p); 15059 until p=null; 15060 flush_list(arg_list); 15061 end 15062 15063@ It's sometimes necessary to put a single argument onto |param_stack|. 15064The |stack_argument| subroutine does this. 15065 15066@p procedure stack_argument(@!p:pointer); 15067begin if param_ptr=max_param_stack then 15068 begin incr(max_param_stack); 15069 if max_param_stack>param_size then 15070 overflow("parameter stack size",param_size); 15071@:METAFONT capacity exceeded parameter stack size}{\quad parameter stack size@> 15072 end; 15073param_stack[param_ptr]:=p; incr(param_ptr); 15074end; 15075 15076@* \[36] Conditional processing. 15077Let's consider now the way \&{if} commands are handled. 15078 15079Conditions can be inside conditions, and this nesting has a stack 15080that is independent of other stacks. 15081Four global variables represent the top of the condition stack: 15082|cond_ptr| points to pushed-down entries, if~any; |cur_if| tells whether 15083we are processing \&{if} or \&{elseif}; |if_limit| specifies 15084the largest code of a |fi_or_else| command that is syntactically legal; 15085and |if_line| is the line number at which the current conditional began. 15086 15087If no conditions are currently in progress, the condition stack has the 15088special state |cond_ptr=null|, |if_limit=normal|, |cur_if=0|, |if_line=0|. 15089Otherwise |cond_ptr| points to a two-word node; the |type|, |name_type|, and 15090|link| fields of the first word contain |if_limit|, |cur_if|, and 15091|cond_ptr| at the next level, and the second word contains the 15092corresponding |if_line|. 15093 15094@d if_node_size=2 {number of words in stack entry for conditionals} 15095@d if_line_field(#)==mem[#+1].int 15096@d if_code=1 {code for \&{if} being evaluated} 15097@d fi_code=2 {code for \&{fi}} 15098@d else_code=3 {code for \&{else}} 15099@d else_if_code=4 {code for \&{elseif}} 15100 15101@<Glob...@>= 15102@!cond_ptr:pointer; {top of the condition stack} 15103@!if_limit:normal..else_if_code; {upper bound on |fi_or_else| codes} 15104@!cur_if:small_number; {type of conditional being worked on} 15105@!if_line:integer; {line where that conditional began} 15106 15107@ @<Set init...@>= 15108cond_ptr:=null; if_limit:=normal; cur_if:=0; if_line:=0; 15109 15110@ @<Put each...@>= 15111primitive("if",if_test,if_code);@/ 15112@!@:if_}{\&{if} primitive@> 15113primitive("fi",fi_or_else,fi_code); eqtb[frozen_fi]:=eqtb[cur_sym];@/ 15114@!@:fi_}{\&{fi} primitive@> 15115primitive("else",fi_or_else,else_code);@/ 15116@!@:else_}{\&{else} primitive@> 15117primitive("elseif",fi_or_else,else_if_code);@/ 15118@!@:else_if_}{\&{elseif} primitive@> 15119 15120@ @<Cases of |print_cmd_mod|...@>= 15121if_test,fi_or_else: case m of 15122 if_code:print("if"); 15123 fi_code:print("fi"); 15124 else_code:print("else"); 15125 othercases print("elseif") 15126 endcases; 15127 15128@ Here is a procedure that ignores text until coming to an \&{elseif}, 15129\&{else}, or \&{fi} at level zero of $\&{if}\ldots\&{fi}$ 15130nesting. After it has acted, |cur_mod| will indicate the token that 15131was found. 15132 15133\MF's smallest two command codes are |if_test| and |fi_or_else|; this 15134makes the skipping process a bit simpler. 15135 15136@p procedure pass_text; 15137label done; 15138var l:integer; 15139begin scanner_status:=skipping; l:=0; warning_info:=line; 15140loop@+ begin get_next; 15141 if cur_cmd<=fi_or_else then 15142 if cur_cmd<fi_or_else then incr(l) 15143 else begin if l=0 then goto done; 15144 if cur_mod=fi_code then decr(l); 15145 end 15146 else @<Decrease the string reference count, 15147 if the current token is a string@>; 15148 end; 15149done: scanner_status:=normal; 15150end; 15151 15152@ @<Decrease the string reference count...@>= 15153if cur_cmd=string_token then delete_str_ref(cur_mod) 15154 15155@ When we begin to process a new \&{if}, we set |if_limit:=if_code|; then 15156if \&{elseif} or \&{else} or \&{fi} occurs before the current \&{if} 15157condition has been evaluated, a colon will be inserted. 15158A construction like `\.{if fi}' would otherwise get \MF\ confused. 15159 15160@<Push the condition stack@>= 15161begin p:=get_node(if_node_size); link(p):=cond_ptr; type(p):=if_limit; 15162name_type(p):=cur_if; if_line_field(p):=if_line; 15163cond_ptr:=p; if_limit:=if_code; if_line:=line; cur_if:=if_code; 15164end 15165 15166@ @<Pop the condition stack@>= 15167begin p:=cond_ptr; if_line:=if_line_field(p); 15168cur_if:=name_type(p); if_limit:=type(p); cond_ptr:=link(p); 15169free_node(p,if_node_size); 15170end 15171 15172@ Here's a procedure that changes the |if_limit| code corresponding to 15173a given value of |cond_ptr|. 15174 15175@p procedure change_if_limit(@!l:small_number;@!p:pointer); 15176label exit; 15177var q:pointer; 15178begin if p=cond_ptr then if_limit:=l {that's the easy case} 15179else begin q:=cond_ptr; 15180 loop@+ begin if q=null then confusion("if"); 15181@:this can't happen if}{\quad if@> 15182 if link(q)=p then 15183 begin type(q):=l; return; 15184 end; 15185 q:=link(q); 15186 end; 15187 end; 15188exit:end; 15189 15190@ The user is supposed to put colons into the proper parts of conditional 15191statements. Therefore, \MF\ has to check for their presence. 15192 15193@p procedure check_colon; 15194begin if cur_cmd<>colon then 15195 begin missing_err(":");@/ 15196@.Missing `:'@> 15197 help2("There should've been a colon after the condition.")@/ 15198 ("I shall pretend that one was there.");@; 15199 back_error; 15200 end; 15201end; 15202 15203@ A condition is started when the |get_x_next| procedure encounters 15204an |if_test| command; in that case |get_x_next| calls |conditional|, 15205which is a recursive procedure. 15206@^recursion@> 15207 15208@p procedure conditional; 15209label exit,done,reswitch,found; 15210var @!save_cond_ptr:pointer; {|cond_ptr| corresponding to this conditional} 15211@!new_if_limit:fi_code..else_if_code; {future value of |if_limit|} 15212@!p:pointer; {temporary register} 15213begin @<Push the condition stack@>;@+save_cond_ptr:=cond_ptr; 15214reswitch: get_boolean; new_if_limit:=else_if_code; 15215if internal[tracing_commands]>unity then 15216 @<Display the boolean value of |cur_exp|@>; 15217found: check_colon; 15218if cur_exp=true_code then 15219 begin change_if_limit(new_if_limit,save_cond_ptr); 15220 return; {wait for \&{elseif}, \&{else}, or \&{fi}} 15221 end; 15222@<Skip to \&{elseif} or \&{else} or \&{fi}, then |goto done|@>; 15223done: cur_if:=cur_mod; if_line:=line; 15224if cur_mod=fi_code then @<Pop the condition stack@> 15225else if cur_mod=else_if_code then goto reswitch 15226else begin cur_exp:=true_code; new_if_limit:=fi_code; get_x_next; goto found; 15227 end; 15228exit:end; 15229 15230@ In a construction like `\&{if} \&{if} \&{true}: $0=1$: \\{foo} 15231\&{else}: \\{bar} \&{fi}', the first \&{else} 15232that we come to after learning that the \&{if} is false is not the 15233\&{else} we're looking for. Hence the following curious logic is needed. 15234 15235@<Skip to \&{elseif}...@>= 15236loop@+ begin pass_text; 15237 if cond_ptr=save_cond_ptr then goto done 15238 else if cur_mod=fi_code then @<Pop the condition stack@>; 15239 end 15240 15241 15242@ @<Display the boolean value...@>= 15243begin begin_diagnostic; 15244if cur_exp=true_code then print("{true}")@+else print("{false}"); 15245end_diagnostic(false); 15246end 15247 15248@ The processing of conditionals is complete except for the following 15249code, which is actually part of |get_x_next|. It comes into play when 15250\&{elseif}, \&{else}, or \&{fi} is scanned. 15251 15252@<Terminate the current conditional and skip to \&{fi}@>= 15253if cur_mod>if_limit then 15254 if if_limit=if_code then {condition not yet evaluated} 15255 begin missing_err(":"); 15256@.Missing `:'@> 15257 back_input; cur_sym:=frozen_colon; ins_error; 15258 end 15259 else begin print_err("Extra "); print_cmd_mod(fi_or_else,cur_mod); 15260@.Extra else@> 15261@.Extra elseif@> 15262@.Extra fi@> 15263 help1("I'm ignoring this; it doesn't match any if."); 15264 error; 15265 end 15266else begin while cur_mod<>fi_code do pass_text; {skip to \&{fi}} 15267 @<Pop the condition stack@>; 15268 end 15269 15270@* \[37] Iterations. 15271To bring our treatment of |get_x_next| to a close, we need to consider what 15272\MF\ does when it sees \&{for}, \&{forsuffixes}, and \&{forever}. 15273 15274There's a global variable |loop_ptr| that keeps track of the \&{for} loops 15275that are currently active. If |loop_ptr=null|, no loops are in progress; 15276otherwise |info(loop_ptr)| points to the iterative text of the current 15277(innermost) loop, and |link(loop_ptr)| points to the data for any other 15278loops that enclose the current one. 15279 15280A loop-control node also has two other fields, called |loop_type| and 15281|loop_list|, whose contents depend on the type of loop: 15282 15283\yskip\indent|loop_type(loop_ptr)=null| means that |loop_list(loop_ptr)| 15284points to a list of one-word nodes whose |info| fields point to the 15285remaining argument values of a suffix list and expression list. 15286 15287\yskip\indent|loop_type(loop_ptr)=void| means that the current loop is 15288`\&{forever}'. 15289 15290\yskip\indent|loop_type(loop_ptr)=p>void| means that |value(p)|, 15291|step_size(p)|, and |final_value(p)| contain the data for an arithmetic 15292progression. 15293 15294\yskip\noindent In the latter case, |p| points to a ``progression node'' 15295whose first word is not used. (No value could be stored there because the 15296link field of words in the dynamic memory area cannot be arbitrary.) 15297 15298@d loop_list_loc(#)==#+1 {where the |loop_list| field resides} 15299@d loop_type(#)==info(loop_list_loc(#)) {the type of \&{for} loop} 15300@d loop_list(#)==link(loop_list_loc(#)) {the remaining list elements} 15301@d loop_node_size=2 {the number of words in a loop control node} 15302@d progression_node_size=4 {the number of words in a progression node} 15303@d step_size(#)==mem[#+2].sc {the step size in an arithmetic progression} 15304@d final_value(#)==mem[#+3].sc {the final value in an arithmetic progression} 15305 15306@<Glob...@>= 15307@!loop_ptr:pointer; {top of the loop-control-node stack} 15308 15309@ @<Set init...@>= 15310loop_ptr:=null; 15311 15312@ If the expressions that define an arithmetic progression in 15313a \&{for} loop don't have known numeric values, the |bad_for| 15314subroutine screams at the user. 15315 15316@p procedure bad_for(@!s:str_number); 15317begin disp_err(null,"Improper "); {show the bad expression above the message} 15318@.Improper...replaced by 0@> 15319print(s); print(" has been replaced by 0"); 15320help4("When you say `for x=a step b until c',")@/ 15321 ("the initial value `a' and the step size `b'")@/ 15322 ("and the final value `c' must have known numeric values.")@/ 15323 ("I'm zeroing this one. Proceed, with fingers crossed."); 15324put_get_flush_error(0); 15325end; 15326 15327@ Here's what \MF\ does when \&{for}, \&{forsuffixes}, or \&{forever} 15328has just been scanned. (This code requires slight familiarity with 15329expression-parsing routines that we have not yet discussed; but it seems 15330to belong in the present part of the program, even though the author 15331didn't write it until later. The reader may wish to come back to it.) 15332 15333@p procedure begin_iteration; 15334label continue,done,found; 15335var @!m:halfword; {|expr_base| (\&{for}) or |suffix_base| (\&{forsuffixes})} 15336@!n:halfword; {hash address of the current symbol} 15337@!p,@!q,@!s,@!pp:pointer; {link manipulation registers} 15338begin m:=cur_mod; n:=cur_sym; s:=get_node(loop_node_size); 15339if m=start_forever then 15340 begin loop_type(s):=void; p:=null; get_x_next; goto found; 15341 end; 15342get_symbol; p:=get_node(token_node_size); info(p):=cur_sym; value(p):=m;@/ 15343get_x_next; 15344if (cur_cmd<>equals)and(cur_cmd<>assignment) then 15345 begin missing_err("=");@/ 15346@.Missing `='@> 15347 help3("The next thing in this loop should have been `=' or `:='.")@/ 15348 ("But don't worry; I'll pretend that an equals sign")@/ 15349 ("was present, and I'll look for the values next.");@/ 15350 back_error; 15351 end; 15352@<Scan the values to be used in the loop@>; 15353found:@<Check for the presence of a colon@>; 15354@<Scan the loop text and put it on the loop control stack@>; 15355resume_iteration; 15356end; 15357 15358@ @<Check for the presence of a colon@>= 15359if cur_cmd<>colon then 15360 begin missing_err(":");@/ 15361@.Missing `:'@> 15362 help3("The next thing in this loop should have been a `:'.")@/ 15363 ("So I'll pretend that a colon was present;")@/ 15364 ("everything from here to `endfor' will be iterated."); 15365 back_error; 15366 end 15367 15368@ We append a special |frozen_repeat_loop| token in place of the 15369`\&{endfor}' at the end of the loop. This will come through \MF's scanner 15370at the proper time to cause the loop to be repeated. 15371 15372(If the user tries some shenanigan like `\&{for} $\ldots$ \&{let} \&{endfor}', 15373he will be foiled by the |get_symbol| routine, which keeps frozen 15374tokens unchanged. Furthermore the |frozen_repeat_loop| is an \&{outer} 15375token, so it won't be lost accidentally.) 15376 15377@ @<Scan the loop text...@>= 15378q:=get_avail; info(q):=frozen_repeat_loop; 15379scanner_status:=loop_defining; warning_info:=n; 15380info(s):=scan_toks(iteration,p,q,0); scanner_status:=normal;@/ 15381link(s):=loop_ptr; loop_ptr:=s 15382 15383@ @<Initialize table...@>= 15384eq_type(frozen_repeat_loop):=repeat_loop+outer_tag; 15385text(frozen_repeat_loop):=" ENDFOR"; 15386 15387@ The loop text is inserted into \MF's scanning apparatus by the 15388|resume_iteration| routine. 15389 15390@p procedure resume_iteration; 15391label not_found,exit; 15392var @!p,@!q:pointer; {link registers} 15393begin p:=loop_type(loop_ptr); 15394if p>void then {|p| points to a progression node} 15395 begin cur_exp:=value(p); 15396 if @<The arithmetic progression has ended@> then goto not_found; 15397 cur_type:=known; q:=stash_cur_exp; {make |q| an \&{expr} argument} 15398 value(p):=cur_exp+step_size(p); {set |value(p)| for the next iteration} 15399 end 15400else if p<void then 15401 begin p:=loop_list(loop_ptr); 15402 if p=null then goto not_found; 15403 loop_list(loop_ptr):=link(p); q:=info(p); free_avail(p); 15404 end 15405else begin begin_token_list(info(loop_ptr),forever_text); return; 15406 end; 15407begin_token_list(info(loop_ptr),loop_text); 15408stack_argument(q); 15409if internal[tracing_commands]>unity then @<Trace the start of a loop@>; 15410return; 15411not_found:stop_iteration; 15412exit:end; 15413 15414@ @<The arithmetic progression has ended@>= 15415((step_size(p)>0)and(cur_exp>final_value(p)))or@| 15416 ((step_size(p)<0)and(cur_exp<final_value(p))) 15417 15418@ @<Trace the start of a loop@>= 15419begin begin_diagnostic; print_nl("{loop value="); 15420@.loop value=n@> 15421if (q<>null)and(link(q)=void) then print_exp(q,1) 15422else show_token_list(q,null,50,0); 15423print_char("}"); end_diagnostic(false); 15424end 15425 15426@ A level of loop control disappears when |resume_iteration| has decided 15427not to resume, or when an \&{exitif} construction has removed the loop text 15428from the input stack. 15429 15430@p procedure stop_iteration; 15431var @!p,@!q:pointer; {the usual} 15432begin p:=loop_type(loop_ptr); 15433if p>void then free_node(p,progression_node_size) 15434else if p<void then 15435 begin q:=loop_list(loop_ptr); 15436 while q<>null do 15437 begin p:=info(q); 15438 if p<>null then 15439 if link(p)=void then {it's an \&{expr} parameter} 15440 begin recycle_value(p); free_node(p,value_node_size); 15441 end 15442 else flush_token_list(p); {it's a \&{suffix} or \&{text} parameter} 15443 p:=q; q:=link(q); free_avail(p); 15444 end; 15445 end; 15446p:=loop_ptr; loop_ptr:=link(p); flush_token_list(info(p)); 15447free_node(p,loop_node_size); 15448end; 15449 15450@ Now that we know all about loop control, we can finish up 15451the missing portion of |begin_iteration| and we'll be done. 15452 15453The following code is performed after the `\.=' has been scanned in 15454a \&{for} construction (if |m=expr_base|) or a \&{forsuffixes} construction 15455(if |m=suffix_base|). 15456 15457@<Scan the values to be used in the loop@>= 15458loop_type(s):=null; q:=loop_list_loc(s); link(q):=null; {|link(q)=loop_list(s)|} 15459repeat get_x_next; 15460if m<>expr_base then scan_suffix 15461else begin if cur_cmd>=colon then if cur_cmd<=comma then goto continue; 15462 scan_expression; 15463 if cur_cmd=step_token then if q=loop_list_loc(s) then 15464 @<Prepare for step-until construction and |goto done|@>; 15465 cur_exp:=stash_cur_exp; 15466 end; 15467link(q):=get_avail; q:=link(q); info(q):=cur_exp; cur_type:=vacuous; 15468continue: until cur_cmd<>comma; 15469done: 15470 15471@ @<Prepare for step-until construction and |goto done|@>= 15472begin if cur_type<>known then bad_for("initial value"); 15473pp:=get_node(progression_node_size); value(pp):=cur_exp;@/ 15474get_x_next; scan_expression; 15475if cur_type<>known then bad_for("step size"); 15476step_size(pp):=cur_exp; 15477if cur_cmd<>until_token then 15478 begin missing_err("until");@/ 15479@.Missing `until'@> 15480 help2("I assume you meant to say `until' after `step'.")@/ 15481 ("So I'll look for the final value and colon next."); 15482 back_error; 15483 end; 15484get_x_next; scan_expression; 15485if cur_type<>known then bad_for("final value"); 15486final_value(pp):=cur_exp; loop_type(s):=pp; goto done; 15487end 15488 15489@* \[38] File names. 15490It's time now to fret about file names. Besides the fact that different 15491operating systems treat files in different ways, we must cope with the 15492fact that completely different naming conventions are used by different 15493groups of people. The following programs show what is required for one 15494particular operating system; similar routines for other systems are not 15495difficult to devise. 15496@^system dependencies@> 15497 15498\MF\ assumes that a file name has three parts: the name proper; its 15499``extension''; and a ``file area'' where it is found in an external file 15500system. The extension of an input file is assumed to be 15501`\.{.mf}' unless otherwise specified; it is `\.{.log}' on the 15502transcript file that records each run of \MF; it is `\.{.tfm}' on the font 15503metric files that describe characters in the fonts \MF\ creates; it is 15504`\.{.gf}' on the output files that specify generic font information; and it 15505is `\.{.base}' on the base files written by \.{INIMF} to initialize \MF. 15506The file area can be arbitrary on input files, but files are usually 15507output to the user's current area. If an input file cannot be 15508found on the specified area, \MF\ will look for it on a special system 15509area; this special area is intended for commonly used input files. 15510 15511Simple uses of \MF\ refer only to file names that have no explicit 15512extension or area. For example, a person usually says `\.{input} \.{cmr10}' 15513instead of `\.{input} \.{cmr10.new}'. Simple file 15514names are best, because they make the \MF\ source files portable; 15515whenever a file name consists entirely of letters and digits, it should be 15516treated in the same way by all implementations of \MF. However, users 15517need the ability to refer to other files in their environment, especially 15518when responding to error messages concerning unopenable files; therefore 15519we want to let them use the syntax that appears in their favorite 15520operating system. 15521 15522@ \MF\ uses the same conventions that have proved to be satisfactory for 15523\TeX. In order to isolate the system-dependent aspects of file names, the 15524@^system dependencies@> 15525system-independent parts of \MF\ are expressed in terms 15526of three system-dependent 15527procedures called |begin_name|, |more_name|, and |end_name|. In 15528essence, if the user-specified characters of the file name are $c_1\ldots c_n$, 15529the system-independent driver program does the operations 15530$$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n); 15531\,|end_name|.$$ 15532These three procedures communicate with each other via global variables. 15533Afterwards the file name will appear in the string pool as three strings 15534called |cur_name|\penalty10000\hskip-.05em, 15535|cur_area|, and |cur_ext|; the latter two are null (i.e., 15536|""|), unless they were explicitly specified by the user. 15537 15538Actually the situation is slightly more complicated, because \MF\ needs 15539to know when the file name ends. The |more_name| routine is a function 15540(with side effects) that returns |true| on the calls |more_name|$(c_1)$, 15541\dots, |more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$ 15542returns |false|; or, it returns |true| and $c_n$ is the last character 15543on the current input line. In other words, 15544|more_name| is supposed to return |true| unless it is sure that the 15545file name has been completely scanned; and |end_name| is supposed to be able 15546to finish the assembly of |cur_name|, |cur_area|, and |cur_ext| regardless of 15547whether $|more_name|(c_n)$ returned |true| or |false|. 15548 15549@<Glob...@>= 15550@!cur_name:str_number; {name of file just scanned} 15551@!cur_area:str_number; {file area just scanned, or \.{""}} 15552@!cur_ext:str_number; {file extension just scanned, or \.{""}} 15553 15554@ The file names we shall deal with for illustrative purposes have the 15555following structure: If the name contains `\.>' or `\.:', the file area 15556consists of all characters up to and including the final such character; 15557otherwise the file area is null. If the remaining file name contains 15558`\..', the file extension consists of all such characters from the first 15559remaining `\..' to the end, otherwise the file extension is null. 15560@^system dependencies@> 15561 15562We can scan such file names easily by using two global variables that keep track 15563of the occurrences of area and extension delimiters: 15564 15565@<Glob...@>= 15566@!area_delimiter:pool_pointer; {the most recent `\.>' or `\.:', if any} 15567@!ext_delimiter:pool_pointer; {the relevant `\..', if any} 15568 15569@ Input files that can't be found in the user's area may appear in a standard 15570system area called |MF_area|. 15571This system area name will, of course, vary from place to place. 15572@^system dependencies@> 15573 15574@d MF_area=="MFinputs:" 15575@.MFinputs@> 15576 15577@ Here now is the first of the system-dependent routines for file name scanning. 15578@^system dependencies@> 15579 15580@p procedure begin_name; 15581begin area_delimiter:=0; ext_delimiter:=0; 15582end; 15583 15584@ And here's the second. 15585@^system dependencies@> 15586 15587@p function more_name(@!c:ASCII_code):boolean; 15588begin if c=" " then more_name:=false 15589else begin if (c=">")or(c=":") then 15590 begin area_delimiter:=pool_ptr; ext_delimiter:=0; 15591 end 15592 else if (c=".")and(ext_delimiter=0) then ext_delimiter:=pool_ptr; 15593 str_room(1); append_char(c); {contribute |c| to the current string} 15594 more_name:=true; 15595 end; 15596end; 15597 15598@ The third. 15599@^system dependencies@> 15600 15601@p procedure end_name; 15602begin if str_ptr+3>max_str_ptr then 15603 begin if str_ptr+3>max_strings then 15604 overflow("number of strings",max_strings-init_str_ptr); 15605@:METAFONT capacity exceeded number of strings}{\quad number of strings@> 15606 max_str_ptr:=str_ptr+3; 15607 end; 15608if area_delimiter=0 then cur_area:="" 15609else begin cur_area:=str_ptr; incr(str_ptr); 15610 str_start[str_ptr]:=area_delimiter+1; 15611 end; 15612if ext_delimiter=0 then 15613 begin cur_ext:=""; cur_name:=make_string; 15614 end 15615else begin cur_name:=str_ptr; incr(str_ptr); 15616 str_start[str_ptr]:=ext_delimiter; cur_ext:=make_string; 15617 end; 15618end; 15619 15620@ Conversely, here is a routine that takes three strings and prints a file 15621name that might have produced them. (The routine is system dependent, because 15622some operating systems put the file area last instead of first.) 15623@^system dependencies@> 15624 15625@<Basic printing...@>= 15626procedure print_file_name(@!n,@!a,@!e:integer); 15627begin slow_print(a); slow_print(n); slow_print(e); 15628end; 15629 15630@ Another system-dependent routine is needed to convert three internal 15631\MF\ strings 15632to the |name_of_file| value that is used to open files. The present code 15633allows both lowercase and uppercase letters in the file name. 15634@^system dependencies@> 15635 15636@d append_to_name(#)==begin c:=#; incr(k); 15637 if k<=file_name_size then name_of_file[k]:=xchr[c]; 15638 end 15639 15640@p procedure pack_file_name(@!n,@!a,@!e:str_number); 15641var @!k:integer; {number of positions filled in |name_of_file|} 15642@!c: ASCII_code; {character being packed} 15643@!j:pool_pointer; {index into |str_pool|} 15644begin k:=0; 15645for j:=str_start[a] to str_start[a+1]-1 do append_to_name(so(str_pool[j])); 15646for j:=str_start[n] to str_start[n+1]-1 do append_to_name(so(str_pool[j])); 15647for j:=str_start[e] to str_start[e+1]-1 do append_to_name(so(str_pool[j])); 15648if k<=file_name_size then name_length:=k@+else name_length:=file_name_size; 15649for k:=name_length+1 to file_name_size do name_of_file[k]:=' '; 15650end; 15651 15652@ A messier routine is also needed, since base file names must be scanned 15653before \MF's string mechanism has been initialized. We shall use the 15654global variable |MF_base_default| to supply the text for default system areas 15655and extensions related to base files. 15656@^system dependencies@> 15657 15658@d base_default_length=18 {length of the |MF_base_default| string} 15659@d base_area_length=8 {length of its area part} 15660@d base_ext_length=5 {length of its `\.{.base}' part} 15661@d base_extension=".base" {the extension, as a \.{WEB} constant} 15662 15663@<Glob...@>= 15664@!MF_base_default:packed array[1..base_default_length] of char; 15665 15666@ @<Set init...@>= 15667MF_base_default:='MFbases:plain.base'; 15668@.MFbases@> 15669@.plain@> 15670@^system dependencies@> 15671 15672@ @<Check the ``constant'' values for consistency@>= 15673if base_default_length>file_name_size then bad:=41; 15674 15675@ Here is the messy routine that was just mentioned. It sets |name_of_file| 15676from the first |n| characters of |MF_base_default|, followed by 15677|buffer[a..b]|, followed by the last |base_ext_length| characters of 15678|MF_base_default|. 15679 15680We dare not give error messages here, since \MF\ calls this routine before 15681the |error| routine is ready to roll. Instead, we simply drop excess characters, 15682since the error will be detected in another way when a strange file name 15683isn't found. 15684@^system dependencies@> 15685 15686@p procedure pack_buffered_name(@!n:small_number;@!a,@!b:integer); 15687var @!k:integer; {number of positions filled in |name_of_file|} 15688@!c: ASCII_code; {character being packed} 15689@!j:integer; {index into |buffer| or |MF_base_default|} 15690begin if n+b-a+1+base_ext_length>file_name_size then 15691 b:=a+file_name_size-n-1-base_ext_length; 15692k:=0; 15693for j:=1 to n do append_to_name(xord[MF_base_default[j]]); 15694for j:=a to b do append_to_name(buffer[j]); 15695for j:=base_default_length-base_ext_length+1 to base_default_length do 15696 append_to_name(xord[MF_base_default[j]]); 15697if k<=file_name_size then name_length:=k@+else name_length:=file_name_size; 15698for k:=name_length+1 to file_name_size do name_of_file[k]:=' '; 15699end; 15700 15701@ Here is the only place we use |pack_buffered_name|. This part of the program 15702becomes active when a ``virgin'' \MF\ is trying to get going, just after 15703the preliminary initialization, or when the user is substituting another 15704base file by typing `\.\&' after the initial `\.{**}' prompt. The buffer 15705contains the first line of input in |buffer[loc..(last-1)]|, where 15706|loc<last| and |buffer[loc]<>" "|. 15707 15708@<Declare the function called |open_base_file|@>= 15709function open_base_file:boolean; 15710label found,exit; 15711var @!j:0..buf_size; {the first space after the file name} 15712begin j:=loc; 15713if buffer[loc]="&" then 15714 begin incr(loc); j:=loc; buffer[last]:=" "; 15715 while buffer[j]<>" " do incr(j); 15716 pack_buffered_name(0,loc,j-1); {try first without the system file area} 15717 if w_open_in(base_file) then goto found; 15718 pack_buffered_name(base_area_length,loc,j-1); 15719 {now try the system base file area} 15720 if w_open_in(base_file) then goto found; 15721 wake_up_terminal; 15722 wterm_ln('Sorry, I can''t find that base;',' will try PLAIN.'); 15723@.Sorry, I can't find...@> 15724 update_terminal; 15725 end; 15726 {now pull out all the stops: try for the system \.{plain} file} 15727pack_buffered_name(base_default_length-base_ext_length,1,0); 15728if not w_open_in(base_file) then 15729 begin wake_up_terminal; 15730 wterm_ln('I can''t find the PLAIN base file!'); 15731@.I can't find PLAIN...@> 15732@.plain@> 15733 open_base_file:=false; return; 15734 end; 15735found:loc:=j; open_base_file:=true; 15736exit:end; 15737 15738@ Operating systems often make it possible to determine the exact name (and 15739possible version number) of a file that has been opened. The following routine, 15740which simply makes a \MF\ string from the value of |name_of_file|, should 15741ideally be changed to deduce the full name of file~|f|, which is the file 15742most recently opened, if it is possible to do this in a \PASCAL\ program. 15743@^system dependencies@> 15744 15745This routine might be called after string memory has overflowed, hence 15746we dare not use `|str_room|'. 15747 15748@p function make_name_string:str_number; 15749var @!k:1..file_name_size; {index into |name_of_file|} 15750begin if (pool_ptr+name_length>pool_size)or(str_ptr=max_strings) then 15751 make_name_string:="?" 15752else begin for k:=1 to name_length do append_char(xord[name_of_file[k]]); 15753 make_name_string:=make_string; 15754 end; 15755end; 15756function a_make_name_string(var @!f:alpha_file):str_number; 15757begin a_make_name_string:=make_name_string; 15758end; 15759function b_make_name_string(var @!f:byte_file):str_number; 15760begin b_make_name_string:=make_name_string; 15761end; 15762function w_make_name_string(var @!f:word_file):str_number; 15763begin w_make_name_string:=make_name_string; 15764end; 15765 15766@ Now let's consider the ``driver'' 15767routines by which \MF\ deals with file names 15768in a system-independent manner. First comes a procedure that looks for a 15769file name in the input by taking the information from the input buffer. 15770(We can't use |get_next|, because the conversion to tokens would 15771destroy necessary information.) 15772 15773This procedure doesn't allow semicolons or percent signs to be part of 15774file names, because of other conventions of \MF. The manual doesn't 15775use semicolons or percents immediately after file names, but some users 15776no doubt will find it natural to do so; therefore system-dependent 15777changes to allow such characters in file names should probably 15778be made with reluctance, and only when an entire file name that 15779includes special characters is ``quoted'' somehow. 15780@^system dependencies@> 15781 15782@p procedure scan_file_name; 15783label done; 15784begin begin_name; 15785while buffer[loc]=" " do incr(loc); 15786loop@+begin if (buffer[loc]=";")or(buffer[loc]="%") then goto done; 15787 if not more_name(buffer[loc]) then goto done; 15788 incr(loc); 15789 end; 15790done: end_name; 15791end; 15792 15793@ The global variable |job_name| contains the file name that was first 15794\&{input} by the user. This name is extended by `\.{.log}' and `\.{.gf}' and 15795`\.{.base}' and `\.{.tfm}' in the names of \MF's output files. 15796 15797@<Glob...@>= 15798@!job_name:str_number; {principal file name} 15799@!log_opened:boolean; {has the transcript file been opened?} 15800@!log_name:str_number; {full name of the log file} 15801 15802@ Initially |job_name=0|; it becomes nonzero as soon as the true name is known. 15803We have |job_name=0| if and only if the `\.{log}' file has not been opened, 15804except of course for a short time just after |job_name| has become nonzero. 15805 15806@<Initialize the output...@>=job_name:=0; log_opened:=false; 15807 15808@ Here is a routine that manufactures the output file names, assuming that 15809|job_name<>0|. It ignores and changes the current settings of |cur_area| 15810and |cur_ext|. 15811 15812@d pack_cur_name==pack_file_name(cur_name,cur_area,cur_ext) 15813 15814@p procedure pack_job_name(@!s:str_number); {|s = ".log"|, |".gf"|, 15815 |".tfm"|, or |base_extension|} 15816begin cur_area:=""; cur_ext:=s; 15817cur_name:=job_name; pack_cur_name; 15818end; 15819 15820@ Actually the main output file extension is usually something like 15821|".300gf"| instead of just |".gf"|; the additional number indicates the 15822resolution in pixels per inch, based on the setting of |hppp| when 15823the file is opened. 15824 15825@<Glob...@>= 15826@!gf_ext:str_number; {default extension for the output file} 15827 15828@ If some trouble arises when \MF\ tries to open a file, the following 15829routine calls upon the user to supply another file name. Parameter~|s| 15830is used in the error message to identify the type of file; parameter~|e| 15831is the default extension if none is given. Upon exit from the routine, 15832variables |cur_name|, |cur_area|, |cur_ext|, and |name_of_file| are 15833ready for another attempt at file opening. 15834 15835@p procedure prompt_file_name(@!s,@!e:str_number); 15836label done; 15837var @!k:0..buf_size; {index into |buffer|} 15838begin if interaction=scroll_mode then wake_up_terminal; 15839if s="input file name" then print_err("I can't find file `") 15840@.I can't find file x@> 15841else print_err("I can't write on file `"); 15842@.I can't write on file x@> 15843print_file_name(cur_name,cur_area,cur_ext); print("'."); 15844if e=".mf" then show_context; 15845print_nl("Please type another "); print(s); 15846@.Please type...@> 15847if interaction<scroll_mode then 15848 fatal_error("*** (job aborted, file error in nonstop mode)"); 15849@.job aborted, file error...@> 15850clear_terminal; prompt_input(": "); @<Scan file name in the buffer@>; 15851if cur_ext="" then cur_ext:=e; 15852pack_cur_name; 15853end; 15854 15855@ @<Scan file name in the buffer@>= 15856begin begin_name; k:=first; 15857while (buffer[k]=" ")and(k<last) do incr(k); 15858loop@+ begin if k=last then goto done; 15859 if not more_name(buffer[k]) then goto done; 15860 incr(k); 15861 end; 15862done:end_name; 15863end 15864 15865@ The |open_log_file| routine is used to open the transcript file and to help 15866it catch up to what has previously been printed on the terminal. 15867 15868@p procedure open_log_file; 15869var @!old_setting:0..max_selector; {previous |selector| setting} 15870@!k:0..buf_size; {index into |months| and |buffer|} 15871@!l:0..buf_size; {end of first input line} 15872@!m:integer; {the current month} 15873@!months:packed array [1..36] of char; {abbreviations of month names} 15874begin old_setting:=selector; 15875if job_name=0 then job_name:="mfput"; 15876@.mfput@> 15877pack_job_name(".log"); 15878while not a_open_out(log_file) do @<Try to get a different log file name@>; 15879log_name:=a_make_name_string(log_file); 15880selector:=log_only; log_opened:=true; 15881@<Print the banner line, including the date and time@>; 15882input_stack[input_ptr]:=cur_input; {make sure bottom level is in memory} 15883print_nl("**"); 15884@.**@> 15885l:=input_stack[0].limit_field-1; {last position of first line} 15886for k:=1 to l do print(buffer[k]); 15887print_ln; {now the transcript file contains the first line of input} 15888selector:=old_setting+2; {|log_only| or |term_and_log|} 15889end; 15890 15891@ Sometimes |open_log_file| is called at awkward moments when \MF\ is 15892unable to print error messages or even to |show_context|. 15893The |prompt_file_name| routine can result in a |fatal_error|, but the |error| 15894routine will not be invoked because |log_opened| will be false. 15895 15896The normal idea of |batch_mode| is that nothing at all should be written 15897on the terminal. However, in the unusual case that 15898no log file could be opened, we make an exception and allow 15899an explanatory message to be seen. 15900 15901Incidentally, the program always refers to the log file as a `\.{transcript 15902file}', because some systems cannot use the extension `\.{.log}' for 15903this file. 15904 15905@<Try to get a different log file name@>= 15906begin selector:=term_only; 15907prompt_file_name("transcript file name",".log"); 15908end 15909 15910@ @<Print the banner...@>= 15911begin wlog(banner); 15912slow_print(base_ident); print(" "); 15913print_int(round_unscaled(internal[day])); print_char(" "); 15914months:='JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'; 15915m:=round_unscaled(internal[month]); 15916for k:=3*m-2 to 3*m do wlog(months[k]); 15917print_char(" "); print_int(round_unscaled(internal[year])); print_char(" "); 15918m:=round_unscaled(internal[time]); 15919print_dd(m div 60); print_char(":"); print_dd(m mod 60); 15920end 15921 15922@ Here's an example of how these file-name-parsing routines work in practice. 15923We shall use the macro |set_output_file_name| when it is time to 15924crank up the output file. 15925 15926@d set_output_file_name== 15927 begin if job_name=0 then open_log_file; 15928 pack_job_name(gf_ext); 15929 while not b_open_out(gf_file) do 15930 prompt_file_name("file name for output",gf_ext); 15931 output_file_name:=b_make_name_string(gf_file); 15932 end 15933 15934@<Glob...@>= 15935@!gf_file: byte_file; {the generic font output goes here} 15936@!output_file_name: str_number; {full name of the output file} 15937 15938@ @<Initialize the output...@>=output_file_name:=0; 15939 15940@ Let's turn now to the procedure that is used to initiate file reading 15941when an `\.{input}' command is being processed. 15942 15943@p procedure start_input; {\MF\ will \.{input} something} 15944label done; 15945begin @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>; 15946if cur_ext="" then cur_ext:=".mf"; 15947pack_cur_name; 15948loop@+ begin begin_file_reading; {set up |cur_file| and new level of input} 15949 if a_open_in(cur_file) then goto done; 15950 if cur_area="" then 15951 begin pack_file_name(cur_name,MF_area,cur_ext); 15952 if a_open_in(cur_file) then goto done; 15953 end; 15954 end_file_reading; {remove the level that didn't work} 15955 prompt_file_name("input file name",".mf"); 15956 end; 15957done: name:=a_make_name_string(cur_file); str_ref[cur_name]:=max_str_ref; 15958if job_name=0 then 15959 begin job_name:=cur_name; open_log_file; 15960 end; {|open_log_file| doesn't |show_context|, so |limit| 15961 and |loc| needn't be set to meaningful values yet} 15962if term_offset+length(name)>max_print_line-2 then print_ln 15963else if (term_offset>0)or(file_offset>0) then print_char(" "); 15964print_char("("); incr(open_parens); slow_print(name); update_terminal; 15965if name=str_ptr-1 then {we can conserve string pool space now} 15966 begin flush_string(name); name:=cur_name; 15967 end; 15968@<Read the first line of the new file@>; 15969end; 15970 15971@ Here we have to remember to tell the |input_ln| routine not to 15972start with a |get|. If the file is empty, it is considered to 15973contain a single blank line. 15974@^system dependencies@> 15975 15976@<Read the first line...@>= 15977begin line:=1; 15978if input_ln(cur_file,false) then do_nothing; 15979firm_up_the_line; 15980buffer[limit]:="%"; first:=limit+1; loc:=start; 15981end 15982 15983@ @<Put the desired file name in |(cur_name,cur_ext,cur_area)|@>= 15984while token_state and(loc=null) do end_token_list; 15985if token_state then 15986 begin print_err("File names can't appear within macros"); 15987@.File names can't...@> 15988 help3("Sorry...I've converted what follows to tokens,")@/ 15989 ("possibly garbaging the name you gave.")@/ 15990 ("Please delete the tokens and insert the name again.");@/ 15991 error; 15992 end; 15993if file_state then scan_file_name 15994else begin cur_name:=""; cur_ext:=""; cur_area:=""; 15995 end 15996 15997@* \[39] Introduction to the parsing routines. 15998We come now to the central nervous system that sparks many of \MF's activities. 15999By evaluating expressions, from their primary constituents to ever larger 16000subexpressions, \MF\ builds the structures that ultimately define fonts of type. 16001 16002Four mutually recursive subroutines are involved in this process: We call them 16003$$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|, 16004and |scan_expression|.}$$ 16005@^recursion@> 16006Each of them is parameterless and begins with the first token to be scanned 16007already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After execution, 16008the value of the primary or secondary or tertiary or expression that was 16009found will appear in the global variables |cur_type| and |cur_exp|. The 16010token following the expression will be represented in |cur_cmd|, |cur_mod|, 16011and |cur_sym|. 16012 16013Technically speaking, the parsing algorithms are ``LL(1),'' more or less; 16014backup mechanisms have been added in order to provide reasonable error 16015recovery. 16016 16017@<Glob...@>= 16018@!cur_type:small_number; {the type of the expression just found} 16019@!cur_exp:integer; {the value of the expression just found} 16020 16021@ @<Set init...@>= 16022cur_exp:=0; 16023 16024@ Many different kinds of expressions are possible, so it is wise to have 16025precise descriptions of what |cur_type| and |cur_exp| mean in all cases: 16026 16027\smallskip\hang 16028|cur_type=vacuous| means that this expression didn't turn out to have a 16029value at all, because it arose from a \&{begingroup}$\,\ldots\,$\&{endgroup} 16030construction in which there was no expression before the \&{endgroup}. 16031In this case |cur_exp| has some irrelevant value. 16032 16033\smallskip\hang 16034|cur_type=boolean_type| means that |cur_exp| is either |true_code| 16035or |false_code|. 16036 16037\smallskip\hang 16038|cur_type=unknown_boolean| means that |cur_exp| points to a capsule 16039node that is in 16040a ring of equivalent booleans whose value has not yet been defined. 16041 16042\smallskip\hang 16043|cur_type=string_type| means that |cur_exp| is a string number (i.e., an 16044integer in the range |0<=cur_exp<str_ptr|). That string's reference count 16045includes this particular reference. 16046 16047\smallskip\hang 16048|cur_type=unknown_string| means that |cur_exp| points to a capsule 16049node that is in 16050a ring of equivalent strings whose value has not yet been defined. 16051 16052\smallskip\hang 16053|cur_type=pen_type| means that |cur_exp| points to a pen header node. This 16054node contains a reference count, which takes account of this particular 16055reference. 16056 16057\smallskip\hang 16058|cur_type=unknown_pen| means that |cur_exp| points to a capsule 16059node that is in 16060a ring of equivalent pens whose value has not yet been defined. 16061 16062\smallskip\hang 16063|cur_type=future_pen| means that |cur_exp| points to a knot list that 16064should eventually be made into a pen. Nobody else points to this particular 16065knot list. The |future_pen| option occurs only as an output of |scan_primary| 16066and |scan_secondary|, not as an output of |scan_tertiary| or |scan_expression|. 16067 16068\smallskip\hang 16069|cur_type=path_type| means that |cur_exp| points to a the first node of 16070a path; nobody else points to this particular path. The control points of 16071the path will have been chosen. 16072 16073\smallskip\hang 16074|cur_type=unknown_path| means that |cur_exp| points to a capsule 16075node that is in 16076a ring of equivalent paths whose value has not yet been defined. 16077 16078\smallskip\hang 16079|cur_type=picture_type| means that |cur_exp| points to an edges header node. 16080Nobody else points to this particular set of edges. 16081 16082\smallskip\hang 16083|cur_type=unknown_picture| means that |cur_exp| points to a capsule 16084node that is in 16085a ring of equivalent pictures whose value has not yet been defined. 16086 16087\smallskip\hang 16088|cur_type=transform_type| means that |cur_exp| points to a |transform_type| 16089capsule node. The |value| part of this capsule 16090points to a transform node that contains six numeric values, 16091each of which is |independent|, |dependent|, |proto_dependent|, or |known|. 16092 16093\smallskip\hang 16094|cur_type=pair_type| means that |cur_exp| points to a capsule 16095node whose type is |pair_type|. The |value| part of this capsule 16096points to a pair node that contains two numeric values, 16097each of which is |independent|, |dependent|, |proto_dependent|, or |known|. 16098 16099\smallskip\hang 16100|cur_type=known| means that |cur_exp| is a |scaled| value. 16101 16102\smallskip\hang 16103|cur_type=dependent| means that |cur_exp| points to a capsule node whose type 16104is |dependent|. The |dep_list| field in this capsule points to the associated 16105dependency list. 16106 16107\smallskip\hang 16108|cur_type=proto_dependent| means that |cur_exp| points to a |proto_dependent| 16109capsule node . The |dep_list| field in this capsule 16110points to the associated dependency list. 16111 16112\smallskip\hang 16113|cur_type=independent| means that |cur_exp| points to a capsule node 16114whose type is |independent|. This somewhat unusual case can arise, for 16115example, in the expression 16116`$x+\&{begingroup}\penalty0\,\&{string}\,x; 0\,\&{endgroup}$'. 16117 16118\smallskip\hang 16119|cur_type=token_list| means that |cur_exp| points to a linked list of 16120tokens. 16121 16122\smallskip\noindent 16123The possible settings of |cur_type| have been listed here in increasing 16124numerical order. Notice that |cur_type| will never be |numeric_type| or 16125|suffixed_macro| or |unsuffixed_macro|, although variables of those types 16126are allowed. Conversely, \MF\ has no variables of type |vacuous| or 16127|token_list|. 16128 16129@ Capsules are two-word nodes that have a similar meaning 16130to |cur_type| and |cur_exp|. Such nodes have |name_type=capsule|, 16131and their |type| field is one of the possibilities for |cur_type| listed above. 16132Also |link<=void| in capsules that aren't part of a token list. 16133 16134The |value| field of a capsule is, in most cases, the value that 16135corresponds to its |type|, as |cur_exp| corresponds to |cur_type|. 16136However, when |cur_exp| would point to a capsule, 16137no extra layer of indirection is present; the |value| 16138field is what would have been called |value(cur_exp)| if it had not been 16139encapsulated. Furthermore, if the type is |dependent| or 16140|proto_dependent|, the |value| field of a capsule is replaced by 16141|dep_list| and |prev_dep| fields, since dependency lists in capsules are 16142always part of the general |dep_list| structure. 16143 16144The |get_x_next| routine is careful not to change the values of |cur_type| 16145and |cur_exp| when it gets an expanded token. However, |get_x_next| might 16146call a macro, which might parse an expression, which might execute lots of 16147commands in a group; hence it's possible that |cur_type| might change 16148from, say, |unknown_boolean| to |boolean_type|, or from |dependent| to 16149|known| or |independent|, during the time |get_x_next| is called. The 16150programs below are careful to stash sensitive intermediate results in 16151capsules, so that \MF's generality doesn't cause trouble. 16152 16153Here's a procedure that illustrates these conventions. It takes 16154the contents of $(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$ 16155and stashes them away in a 16156capsule. It is not used when |cur_type=token_list|. 16157After the operation, |cur_type=vacuous|; hence there is no need to 16158copy path lists or to update reference counts, etc. 16159 16160The special link |void| is put on the capsule returned by 16161|stash_cur_exp|, because this procedure is used to store macro parameters 16162that must be easily distinguishable from token lists. 16163 16164@<Declare the stashing/unstashing routines@>= 16165function stash_cur_exp:pointer; 16166var @!p:pointer; {the capsule that will be returned} 16167begin case cur_type of 16168unknown_types,transform_type,pair_type,dependent,proto_dependent, 16169 independent:p:=cur_exp; 16170othercases begin p:=get_node(value_node_size); name_type(p):=capsule; 16171 type(p):=cur_type; value(p):=cur_exp; 16172 end 16173endcases;@/ 16174cur_type:=vacuous; link(p):=void; stash_cur_exp:=p; 16175end; 16176 16177@ The inverse of |stash_cur_exp| is the following procedure, which 16178deletes an unnecessary capsule and puts its contents into |cur_type| 16179and |cur_exp|. 16180 16181The program steps of \MF\ can be divided into two categories: those in 16182which |cur_type| and |cur_exp| are ``alive'' and those in which they are 16183``dead,'' in the sense that |cur_type| and |cur_exp| contain relevant 16184information or not. It's important not to ignore them when they're alive, 16185and it's important not to pay attention to them when they're dead. 16186 16187There's also an intermediate category: If |cur_type=vacuous|, then 16188|cur_exp| is irrelevant, hence we can proceed without caring if |cur_type| 16189and |cur_exp| are alive or dead. In such cases we say that |cur_type| 16190and |cur_exp| are {\sl dormant}. It is permissible to call |get_x_next| 16191only when they are alive or dormant. 16192 16193The \\{stash} procedure above assumes that |cur_type| and |cur_exp| 16194are alive or dormant. The \\{unstash} procedure assumes that they are 16195dead or dormant; it resuscitates them. 16196 16197@<Declare the stashing/unstashing...@>= 16198procedure unstash_cur_exp(@!p:pointer); 16199begin cur_type:=type(p); 16200case cur_type of 16201unknown_types,transform_type,pair_type,dependent,proto_dependent, 16202 independent: cur_exp:=p; 16203othercases begin cur_exp:=value(p); 16204 free_node(p,value_node_size); 16205 end 16206endcases;@/ 16207end; 16208 16209@ The following procedure prints the values of expressions in an 16210abbreviated format. If its first parameter |p| is null, the value of 16211|(cur_type,cur_exp)| is displayed; otherwise |p| should be a capsule 16212containing the desired value. The second parameter controls the amount of 16213output. If it is~0, dependency lists will be abbreviated to 16214`\.{linearform}' unless they consist of a single term. If it is greater 16215than~1, complicated structures (pens, pictures, and paths) will be displayed 16216in full. 16217@.linearform@> 16218 16219@<Declare subroutines for printing expressions@>= 16220@t\4@>@<Declare the procedure called |print_dp|@>@; 16221@t\4@>@<Declare the stashing/unstashing routines@>@; 16222procedure print_exp(@!p:pointer;@!verbosity:small_number); 16223var @!restore_cur_exp:boolean; {should |cur_exp| be restored?} 16224@!t:small_number; {the type of the expression} 16225@!v:integer; {the value of the expression} 16226@!q:pointer; {a big node being displayed} 16227begin if p<>null then restore_cur_exp:=false 16228else begin p:=stash_cur_exp; restore_cur_exp:=true; 16229 end; 16230t:=type(p); 16231if t<dependent then v:=value(p)@+else if t<independent then v:=dep_list(p); 16232@<Print an abbreviated value of |v| with format depending on |t|@>; 16233if restore_cur_exp then unstash_cur_exp(p); 16234end; 16235 16236@ @<Print an abbreviated value of |v| with format depending on |t|@>= 16237case t of 16238vacuous:print("vacuous"); 16239boolean_type:if v=true_code then print("true")@+else print("false"); 16240unknown_types,numeric_type:@<Display a variable 16241 that's been declared but not defined@>; 16242string_type:begin print_char(""""); slow_print(v); print_char(""""); 16243 end; 16244pen_type,future_pen,path_type,picture_type:@<Display a complex type@>; 16245transform_type,pair_type:if v=null then print_type(t) 16246 else @<Display a big node@>; 16247known:print_scaled(v); 16248dependent,proto_dependent:print_dp(t,v,verbosity); 16249independent:print_variable_name(p); 16250othercases confusion("exp") 16251@:this can't happen exp}{\quad exp@> 16252endcases 16253 16254@ @<Display a big node@>= 16255begin print_char("("); q:=v+big_node_size[t]; 16256repeat if type(v)=known then print_scaled(value(v)) 16257else if type(v)=independent then print_variable_name(v) 16258else print_dp(type(v),dep_list(v),verbosity); 16259v:=v+2; 16260if v<>q then print_char(","); 16261until v=q; 16262print_char(")"); 16263end 16264 16265@ Values of type \&{picture}, \&{path}, and \&{pen} are displayed verbosely 16266in the log file only, unless the user has given a positive value to 16267\\{tracingonline}. 16268 16269@<Display a complex type@>= 16270if verbosity<=1 then print_type(t) 16271else begin if selector=term_and_log then 16272 if internal[tracing_online]<=0 then 16273 begin selector:=term_only; 16274 print_type(t); print(" (see the transcript file)"); 16275 selector:=term_and_log; 16276 end; 16277 case t of 16278 pen_type:print_pen(v,"",false); 16279 future_pen:print_path(v," (future pen)",false); 16280 path_type:print_path(v,"",false); 16281 picture_type:begin cur_edges:=v; print_edges("",false,0,0); 16282 end; 16283 end; {there are no other cases} 16284 end 16285 16286@ @<Declare the procedure called |print_dp|@>= 16287procedure print_dp(@!t:small_number;@!p:pointer;@!verbosity:small_number); 16288var @!q:pointer; {the node following |p|} 16289begin q:=link(p); 16290if (info(q)=null) or (verbosity>0) then print_dependency(p,t) 16291else print("linearform"); 16292@.linearform@> 16293end; 16294 16295@ The displayed name of a variable in a ring will not be a capsule unless 16296the ring consists entirely of capsules. 16297 16298@<Display a variable that's been declared but not defined@>= 16299begin print_type(t); 16300if v<>null then 16301 begin print_char(" "); 16302 while (name_type(v)=capsule) and (v<>p) do v:=value(v); 16303 print_variable_name(v); 16304 end; 16305end 16306 16307@ When errors are detected during parsing, it is often helpful to 16308display an expression just above the error message, using |exp_err| 16309or |disp_err| instead of |print_err|. 16310 16311@d exp_err(#)==disp_err(null,#) {displays the current expression} 16312 16313@<Declare subroutines for printing expressions@>= 16314procedure disp_err(@!p:pointer;@!s:str_number); 16315begin if interaction=error_stop_mode then wake_up_terminal; 16316print_nl(">> "); 16317@.>>@> 16318print_exp(p,1); {``medium verbose'' printing of the expression} 16319if s<>"" then 16320 begin print_nl("! "); print(s); 16321@.!\relax@> 16322 end; 16323end; 16324 16325@ If |cur_type| and |cur_exp| contain relevant information that should 16326be recycled, we will use the following procedure, which changes |cur_type| 16327to |known| and stores a given value in |cur_exp|. We can think of |cur_type| 16328and |cur_exp| as either alive or dormant after this has been done, 16329because |cur_exp| will not contain a pointer value. 16330 16331@<Declare the procedure called |flush_cur_exp|@>= 16332procedure flush_cur_exp(@!v:scaled); 16333begin case cur_type of 16334unknown_types,transform_type,pair_type,@|dependent,proto_dependent,independent: 16335 begin recycle_value(cur_exp); free_node(cur_exp,value_node_size); 16336 end; 16337pen_type: delete_pen_ref(cur_exp); 16338string_type:delete_str_ref(cur_exp); 16339future_pen,path_type: toss_knot_list(cur_exp); 16340picture_type:toss_edges(cur_exp); 16341othercases do_nothing 16342endcases;@/ 16343cur_type:=known; cur_exp:=v; 16344end; 16345 16346@ There's a much more general procedure that is capable of releasing 16347the storage associated with any two-word value packet. 16348 16349@<Declare the recycling subroutines@>= 16350procedure recycle_value(@!p:pointer); 16351label done; 16352var @!t:small_number; {a type code} 16353@!v:integer; {a value} 16354@!vv:integer; {another value} 16355@!q,@!r,@!s,@!pp:pointer; {link manipulation registers} 16356begin t:=type(p); 16357if t<dependent then v:=value(p); 16358case t of 16359undefined,vacuous,boolean_type,known,numeric_type:do_nothing; 16360unknown_types:ring_delete(p); 16361string_type:delete_str_ref(v); 16362pen_type:delete_pen_ref(v); 16363path_type,future_pen:toss_knot_list(v); 16364picture_type:toss_edges(v); 16365pair_type,transform_type:@<Recycle a big node@>; 16366dependent,proto_dependent:@<Recycle a dependency list@>; 16367independent:@<Recycle an independent variable@>; 16368token_list,structured:confusion("recycle"); 16369@:this can't happen recycle}{\quad recycle@> 16370unsuffixed_macro,suffixed_macro:delete_mac_ref(value(p)); 16371end; {there are no other cases} 16372type(p):=undefined; 16373end; 16374 16375@ @<Recycle a big node@>= 16376if v<>null then 16377 begin q:=v+big_node_size[t]; 16378 repeat q:=q-2; recycle_value(q); 16379 until q=v; 16380 free_node(v,big_node_size[t]); 16381 end 16382 16383@ @<Recycle a dependency list@>= 16384begin q:=dep_list(p); 16385while info(q)<>null do q:=link(q); 16386link(prev_dep(p)):=link(q); 16387prev_dep(link(q)):=prev_dep(p); 16388link(q):=null; flush_node_list(dep_list(p)); 16389end 16390 16391@ When an independent variable disappears, it simply fades away, unless 16392something depends on it. In the latter case, a dependent variable whose 16393coefficient of dependence is maximal will take its place. 16394The relevant algorithm is due to Ignacio~A. Zabala, who implemented it 16395as part of his Ph.D. thesis (Stanford University, December 1982). 16396@^Zabala Salelles, Ignacio Andr\'es@> 16397 16398For example, suppose that variable $x$ is being recycled, and that the 16399only variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case 16400we want to make $y$ independent and $z=.5y-.5a+b$; no other variables 16401will depend on~$y$. If $\\{tracingequations}>0$ in this situation, 16402we will print `\.{\#\#\# -2x=-y+a}'. 16403 16404There's a slight complication, however: An independent variable $x$ 16405can occur both in dependency lists and in proto-dependency lists. 16406This makes it necessary to be careful when deciding which coefficient 16407is maximal. 16408 16409Furthermore, this complication is not so slight when 16410a proto-dependent variable is chosen to become independent. For example, 16411suppose that $y=2x+100a$ is proto-dependent while $z=x+b$ is dependent; 16412then we must change $z=.5y-50a+b$ to a proto-dependency, because of the 16413large coefficient `50'. 16414 16415In order to deal with these complications without wasting too much time, 16416we shall link together the occurrences of~$x$ among all the linear 16417dependencies, maintaining separate lists for the dependent and 16418proto-dependent cases. 16419 16420@<Recycle an independent variable@>= 16421begin max_c[dependent]:=0; max_c[proto_dependent]:=0;@/ 16422max_link[dependent]:=null; max_link[proto_dependent]:=null;@/ 16423q:=link(dep_head); 16424while q<>dep_head do 16425 begin s:=value_loc(q); {now |link(s)=dep_list(q)|} 16426 loop@+ begin r:=link(s); 16427 if info(r)=null then goto done; 16428 if info(r)<>p then s:=r 16429 else begin t:=type(q); link(s):=link(r); info(r):=q; 16430 if abs(value(r))>max_c[t] then 16431 @<Record a new maximum coefficient of type |t|@> 16432 else begin link(r):=max_link[t]; max_link[t]:=r; 16433 end; 16434 end; 16435 end; 16436done: q:=link(r); 16437 end; 16438if (max_c[dependent]>0)or(max_c[proto_dependent]>0) then 16439 @<Choose a dependent variable to take the place of the disappearing 16440 independent variable, and change all remaining dependencies 16441 accordingly@>; 16442end 16443 16444@ The code for independency removal makes use of three two-word arrays. 16445 16446@<Glob...@>= 16447@!max_c:array[dependent..proto_dependent] of integer; 16448 {max coefficient magnitude} 16449@!max_ptr:array[dependent..proto_dependent] of pointer; 16450 {where |p| occurs with |max_c|} 16451@!max_link:array[dependent..proto_dependent] of pointer; 16452 {other occurrences of |p|} 16453 16454@ @<Record a new maximum coefficient...@>= 16455begin if max_c[t]>0 then 16456 begin link(max_ptr[t]):=max_link[t]; max_link[t]:=max_ptr[t]; 16457 end; 16458max_c[t]:=abs(value(r)); max_ptr[t]:=r; 16459end 16460 16461@ @<Choose a dependent...@>= 16462begin if (max_c[dependent] div @'10000 >= 16463 max_c[proto_dependent]) then 16464 t:=dependent 16465else t:=proto_dependent; 16466@<Determine the dependency list |s| to substitute for the independent 16467 variable~|p|@>; 16468t:=dependent+proto_dependent-t; {complement |t|} 16469if max_c[t]>0 then {we need to pick up an unchosen dependency} 16470 begin link(max_ptr[t]):=max_link[t]; max_link[t]:=max_ptr[t]; 16471 end; 16472if t<>dependent then @<Substitute new dependencies in place of |p|@> 16473else @<Substitute new proto-dependencies in place of |p|@>; 16474flush_node_list(s); 16475if fix_needed then fix_dependencies; 16476check_arith; 16477end 16478 16479@ Let |s=max_ptr[t]|. At this point we have $|value|(s)=\pm|max_c|[t]$, 16480and |info(s)| points to the dependent variable~|pp| of type~|t| from 16481whose dependency list we have removed node~|s|. We must reinsert 16482node~|s| into the dependency list, with coefficient $-1.0$, and with 16483|pp| as the new independent variable. Since |pp| will have a larger serial 16484number than any other variable, we can put node |s| at the head of the 16485list. 16486 16487@<Determine the dep...@>= 16488s:=max_ptr[t]; pp:=info(s); v:=value(s); 16489if t=dependent then value(s):=-fraction_one@+else value(s):=-unity; 16490r:=dep_list(pp); link(s):=r; 16491while info(r)<>null do r:=link(r); 16492q:=link(r); link(r):=null; 16493prev_dep(q):=prev_dep(pp); link(prev_dep(pp)):=q; 16494new_indep(pp); 16495if cur_exp=pp then if cur_type=t then cur_type:=independent; 16496if internal[tracing_equations]>0 then @<Show the transformed dependency@> 16497 16498@ Now $(-v)$ times the formerly independent variable~|p| is being replaced 16499by the dependency list~|s|. 16500 16501@<Show the transformed...@>= 16502if interesting(p) then 16503 begin begin_diagnostic; print_nl("### "); 16504@:]]]\#\#\#_}{\.{\#\#\#}@> 16505 if v>0 then print_char("-"); 16506 if t=dependent then vv:=round_fraction(max_c[dependent]) 16507 else vv:=max_c[proto_dependent]; 16508 if vv<>unity then print_scaled(vv); 16509 print_variable_name(p); 16510 while value(p) mod s_scale>0 do 16511 begin print("*4"); value(p):=value(p)-2; 16512 end; 16513 if t=dependent then print_char("=")@+else print(" = "); 16514 print_dependency(s,t); 16515 end_diagnostic(false); 16516 end 16517 16518@ Finally, there are dependent and proto-dependent variables whose 16519dependency lists must be brought up to date. 16520 16521@<Substitute new dependencies...@>= 16522for t:=dependent to proto_dependent do 16523 begin r:=max_link[t]; 16524 while r<>null do 16525 begin q:=info(r); 16526 dep_list(q):=p_plus_fq(dep_list(q),@| 16527 make_fraction(value(r),-v),s,t,dependent); 16528 if dep_list(q)=dep_final then make_known(q,dep_final); 16529 q:=r; r:=link(r); free_node(q,dep_node_size); 16530 end; 16531 end 16532 16533@ @<Substitute new proto...@>= 16534for t:=dependent to proto_dependent do 16535 begin r:=max_link[t]; 16536 while r<>null do 16537 begin q:=info(r); 16538 if t=dependent then {for safety's sake, we change |q| to |proto_dependent|} 16539 begin if cur_exp=q then if cur_type=dependent then 16540 cur_type:=proto_dependent; 16541 dep_list(q):=p_over_v(dep_list(q),unity,dependent,proto_dependent); 16542 type(q):=proto_dependent; value(r):=round_fraction(value(r)); 16543 end; 16544 dep_list(q):=p_plus_fq(dep_list(q),@| 16545 make_scaled(value(r),-v),s,proto_dependent,proto_dependent); 16546 if dep_list(q)=dep_final then make_known(q,dep_final); 16547 q:=r; r:=link(r); free_node(q,dep_node_size); 16548 end; 16549 end 16550 16551@ Here are some routines that provide handy combinations of actions 16552that are often needed during error recovery. For example, 16553`|flush_error|' flushes the current expression, replaces it by 16554a given value, and calls |error|. 16555 16556Errors often are detected after an extra token has already been scanned. 16557The `\\{put\_get}' routines put that token back before calling |error|; 16558then they get it back again. (Or perhaps they get another token, if 16559the user has changed things.) 16560 16561@<Declare the procedure called |flush_cur_exp|@>= 16562procedure flush_error(@!v:scaled);@+begin error; flush_cur_exp(v);@+end; 16563@# 16564procedure@?back_error; forward;@t\2@>@/ 16565procedure@?get_x_next; forward;@t\2@>@/ 16566@# 16567procedure put_get_error;@+begin back_error; get_x_next;@+end; 16568@# 16569procedure put_get_flush_error(@!v:scaled);@+begin put_get_error; 16570 flush_cur_exp(v);@+end; 16571 16572@ A global variable called |var_flag| is set to a special command code 16573just before \MF\ calls |scan_expression|, if the expression should be 16574treated as a variable when this command code immediately follows. For 16575example, |var_flag| is set to |assignment| at the beginning of a 16576statement, because we want to know the {\sl location\/} of a variable at 16577the left of `\.{:=}', not the {\sl value\/} of that variable. 16578 16579The |scan_expression| subroutine calls |scan_tertiary|, 16580which calls |scan_secondary|, which calls |scan_primary|, which sets 16581|var_flag:=0|. In this way each of the scanning routines ``knows'' 16582when it has been called with a special |var_flag|, but |var_flag| is 16583usually zero. 16584 16585A variable preceding a command that equals |var_flag| is converted to a 16586token list rather than a value. Furthermore, an `\.{=}' sign following an 16587expression with |var_flag=assignment| is not considered to be a relation 16588that produces boolean expressions. 16589 16590 16591@<Glob...@>= 16592@!var_flag:0..max_command_code; {command that wants a variable} 16593 16594@ @<Set init...@>= 16595var_flag:=0; 16596 16597@* \[40] Parsing primary expressions. 16598The first parsing routine, |scan_primary|, is also the most complicated one, 16599since it involves so many different cases. But each case---with one 16600exception---is fairly simple by itself. 16601 16602When |scan_primary| begins, the first token of the primary to be scanned 16603should already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values 16604of |cur_type| and |cur_exp| should be either dead or dormant, as explained 16605earlier. If |cur_cmd| is not between |min_primary_command| and 16606|max_primary_command|, inclusive, a syntax error will be signalled. 16607 16608@<Declare the basic parsing subroutines@>= 16609procedure scan_primary; 16610label restart, done, done1, done2; 16611var @!p,@!q,@!r:pointer; {for list manipulation} 16612@!c:quarterword; {a primitive operation code} 16613@!my_var_flag:0..max_command_code; {initial value of |var_flag|} 16614@!l_delim,@!r_delim:pointer; {hash addresses of a delimiter pair} 16615@<Other local variables for |scan_primary|@>@; 16616begin my_var_flag:=var_flag; var_flag:=0; 16617restart:check_arith; 16618@<Supply diagnostic information, if requested@>; 16619case cur_cmd of 16620left_delimiter:@<Scan a delimited primary@>; 16621begin_group:@<Scan a grouped primary@>; 16622string_token:@<Scan a string constant@>; 16623numeric_token:@<Scan a primary that starts with a numeric token@>; 16624nullary:@<Scan a nullary operation@>; 16625unary,type_name,cycle,plus_or_minus:@<Scan a unary operation@>; 16626primary_binary:@<Scan a binary operation with `\&{of}' between its operands@>; 16627str_op:@<Convert a suffix to a string@>; 16628internal_quantity:@<Scan an internal numeric quantity@>; 16629capsule_token:make_exp_copy(cur_mod); 16630tag_token:@<Scan a variable primary; 16631 |goto restart| if it turns out to be a macro@>; 16632othercases begin bad_exp("A primary"); goto restart; 16633@.A primary expression...@> 16634 end 16635endcases;@/ 16636get_x_next; {the routines |goto done| if they don't want this} 16637done: if cur_cmd=left_bracket then 16638 if cur_type>=known then @<Scan a mediation construction@>; 16639end; 16640 16641@ Errors at the beginning of expressions are flagged by |bad_exp|. 16642 16643@p procedure bad_exp(@!s:str_number); 16644var save_flag:0..max_command_code; 16645begin print_err(s); print(" expression can't begin with `"); 16646print_cmd_mod(cur_cmd,cur_mod); print_char("'"); 16647help4("I'm afraid I need some sort of value in order to continue,")@/ 16648 ("so I've tentatively inserted `0'. You may want to")@/ 16649 ("delete this zero and insert something else;")@/ 16650 ("see Chapter 27 of The METAFONTbook for an example."); 16651@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 16652back_input; cur_sym:=0; cur_cmd:=numeric_token; cur_mod:=0; ins_error;@/ 16653save_flag:=var_flag; var_flag:=0; get_x_next; 16654var_flag:=save_flag; 16655end; 16656 16657@ @<Supply diagnostic information, if requested@>= 16658debug if panicking then check_mem(false);@+gubed@;@/ 16659if interrupt<>0 then if OK_to_interrupt then 16660 begin back_input; check_interrupt; get_x_next; 16661 end 16662 16663@ @<Scan a delimited primary@>= 16664begin l_delim:=cur_sym; r_delim:=cur_mod; get_x_next; scan_expression; 16665if (cur_cmd=comma) and (cur_type>=known) then 16666 @<Scan the second of a pair of numerics@> 16667else check_delimiter(l_delim,r_delim); 16668end 16669 16670@ The |stash_in| subroutine puts the current (numeric) expression into a field 16671within a ``big node.'' 16672 16673@p procedure stash_in(@!p:pointer); 16674var @!q:pointer; {temporary register} 16675begin type(p):=cur_type; 16676if cur_type=known then value(p):=cur_exp 16677else begin if cur_type=independent then 16678 @<Stash an independent |cur_exp| into a big node@> 16679 else begin mem[value_loc(p)]:=mem[value_loc(cur_exp)]; 16680 {|dep_list(p):=dep_list(cur_exp)| and |prev_dep(p):=prev_dep(cur_exp)|} 16681 link(prev_dep(p)):=p; 16682 end; 16683 free_node(cur_exp,value_node_size); 16684 end; 16685cur_type:=vacuous; 16686end; 16687 16688@ In rare cases the current expression can become |independent|. There 16689may be many dependency lists pointing to such an independent capsule, 16690so we can't simply move it into place within a big node. Instead, 16691we copy it, then recycle it. 16692 16693@ @<Stash an independent |cur_exp|...@>= 16694begin q:=single_dependency(cur_exp); 16695if q=dep_final then 16696 begin type(p):=known; value(p):=0; free_node(q,dep_node_size); 16697 end 16698else begin type(p):=dependent; new_dep(p,q); 16699 end; 16700recycle_value(cur_exp); 16701end 16702 16703@ @<Scan the second of a pair of numerics@>= 16704begin p:=get_node(value_node_size); type(p):=pair_type; name_type(p):=capsule; 16705init_big_node(p); q:=value(p); stash_in(x_part_loc(q));@/ 16706get_x_next; scan_expression; 16707if cur_type<known then 16708 begin exp_err("Nonnumeric ypart has been replaced by 0"); 16709@.Nonnumeric...replaced by 0@> 16710 help4("I thought you were giving me a pair `(x,y)'; but")@/ 16711 ("after finding a nice xpart `x' I found a ypart `y'")@/ 16712 ("that isn't of numeric type. So I've changed y to zero.")@/ 16713 ("(The y that I didn't like appears above the error message.)"); 16714 put_get_flush_error(0); 16715 end; 16716stash_in(y_part_loc(q)); 16717check_delimiter(l_delim,r_delim); 16718cur_type:=pair_type; cur_exp:=p; 16719end 16720 16721@ The local variable |group_line| keeps track of the line 16722where a \&{begingroup} command occurred; this will be useful 16723in an error message if the group doesn't actually end. 16724 16725@<Other local variables for |scan_primary|@>= 16726@!group_line:integer; {where a group began} 16727 16728@ @<Scan a grouped primary@>= 16729begin group_line:=line; 16730if internal[tracing_commands]>0 then show_cur_cmd_mod; 16731save_boundary_item(p); 16732repeat do_statement; {ends with |cur_cmd>=semicolon|} 16733until cur_cmd<>semicolon; 16734if cur_cmd<>end_group then 16735 begin print_err("A group begun on line "); 16736@.A group...never ended@> 16737 print_int(group_line); 16738 print(" never ended"); 16739 help2("I saw a `begingroup' back there that hasn't been matched")@/ 16740 ("by `endgroup'. So I've inserted `endgroup' now."); 16741 back_error; cur_cmd:=end_group; 16742 end; 16743unsave; {this might change |cur_type|, if independent variables are recycled} 16744if internal[tracing_commands]>0 then show_cur_cmd_mod; 16745end 16746 16747@ @<Scan a string constant@>= 16748begin cur_type:=string_type; cur_exp:=cur_mod; 16749end 16750 16751@ Later we'll come to procedures that perform actual operations like 16752addition, square root, and so on; our purpose now is to do the parsing. 16753But we might as well mention those future procedures now, so that the 16754suspense won't be too bad: 16755 16756\smallskip 16757|do_nullary(c)| does primitive operations that have no operands (e.g., 16758`\&{true}' or `\&{pencircle}'); 16759 16760\smallskip 16761|do_unary(c)| applies a primitive operation to the current expression; 16762 16763\smallskip 16764|do_binary(p,c)| applies a primitive operation to the capsule~|p| 16765and the current expression. 16766 16767@<Scan a nullary operation@>=do_nullary(cur_mod) 16768 16769@ @<Scan a unary operation@>= 16770begin c:=cur_mod; get_x_next; scan_primary; do_unary(c); goto done; 16771end 16772 16773@ A numeric token might be a primary by itself, or it might be the 16774numerator of a fraction composed solely of numeric tokens, or it might 16775multiply the primary that follows (provided that the primary doesn't begin 16776with a plus sign or a minus sign). The code here uses the facts that 16777|max_primary_command=plus_or_minus| and 16778|max_primary_command-1=numeric_token|. If a fraction is found that is less 16779than unity, we try to retain higher precision when we use it in scalar 16780multiplication. 16781 16782@<Other local variables for |scan_primary|@>= 16783@!num,@!denom:scaled; {for primaries that are fractions, like `1/2'} 16784 16785@ @<Scan a primary that starts with a numeric token@>= 16786begin cur_exp:=cur_mod; cur_type:=known; get_x_next; 16787if cur_cmd<>slash then 16788 begin num:=0; denom:=0; 16789 end 16790else begin get_x_next; 16791 if cur_cmd<>numeric_token then 16792 begin back_input; 16793 cur_cmd:=slash; cur_mod:=over; cur_sym:=frozen_slash; 16794 goto done; 16795 end; 16796 num:=cur_exp; denom:=cur_mod; 16797 if denom=0 then @<Protest division by zero@> 16798 else cur_exp:=make_scaled(num,denom); 16799 check_arith; get_x_next; 16800 end; 16801if cur_cmd>=min_primary_command then 16802 if cur_cmd<numeric_token then {in particular, |cur_cmd<>plus_or_minus|} 16803 begin p:=stash_cur_exp; scan_primary; 16804 if (abs(num)>=abs(denom))or(cur_type<pair_type) then do_binary(p,times) 16805 else begin frac_mult(num,denom); 16806 free_node(p,value_node_size); 16807 end; 16808 end; 16809goto done; 16810end 16811 16812@ @<Protest division...@>= 16813begin print_err("Division by zero"); 16814@.Division by zero@> 16815help1("I'll pretend that you meant to divide by 1."); error; 16816end 16817 16818@ @<Scan a binary operation with `\&{of}' between its operands@>= 16819begin c:=cur_mod; get_x_next; scan_expression; 16820if cur_cmd<>of_token then 16821 begin missing_err("of"); print(" for "); print_cmd_mod(primary_binary,c); 16822@.Missing `of'@> 16823 help1("I've got the first argument; will look now for the other."); 16824 back_error; 16825 end; 16826p:=stash_cur_exp; get_x_next; scan_primary; do_binary(p,c); goto done; 16827end 16828 16829@ @<Convert a suffix to a string@>= 16830begin get_x_next; scan_suffix; old_setting:=selector; selector:=new_string; 16831show_token_list(cur_exp,null,100000,0); flush_token_list(cur_exp); 16832cur_exp:=make_string; selector:=old_setting; cur_type:=string_type; 16833goto done; 16834end 16835 16836@ If an internal quantity appears all by itself on the left of an 16837assignment, we return a token list of length one, containing the address 16838of the internal quantity plus |hash_end|. (This accords with the conventions 16839of the save stack, as described earlier.) 16840 16841@<Scan an internal...@>= 16842begin q:=cur_mod; 16843if my_var_flag=assignment then 16844 begin get_x_next; 16845 if cur_cmd=assignment then 16846 begin cur_exp:=get_avail; 16847 info(cur_exp):=q+hash_end; cur_type:=token_list; goto done; 16848 end; 16849 back_input; 16850 end; 16851cur_type:=known; cur_exp:=internal[q]; 16852end 16853 16854@ The most difficult part of |scan_primary| has been saved for last, since 16855it was necessary to build up some confidence first. We can now face the task 16856of scanning a variable. 16857 16858As we scan a variable, we build a token list containing the relevant 16859names and subscript values, simultaneously following along in the 16860``collective'' structure to see if we are actually dealing with a macro 16861instead of a value. 16862 16863The local variables |pre_head| and |post_head| will point to the beginning 16864of the prefix and suffix lists; |tail| will point to the end of the list 16865that is currently growing. 16866 16867Another local variable, |tt|, contains partial information about the 16868declared type of the variable-so-far. If |tt>=unsuffixed_macro|, the 16869relation |tt=type(q)| will always hold. If |tt=undefined|, the routine 16870doesn't bother to update its information about type. And if 16871|undefined<tt<unsuffixed_macro|, the precise value of |tt| isn't critical. 16872 16873@ @<Other local variables for |scan_primary|@>= 16874@!pre_head,@!post_head,@!tail:pointer; 16875 {prefix and suffix list variables} 16876@!tt:small_number; {approximation to the type of the variable-so-far} 16877@!t:pointer; {a token} 16878@!macro_ref:pointer; {reference count for a suffixed macro} 16879 16880@ @<Scan a variable primary...@>= 16881begin fast_get_avail(pre_head); tail:=pre_head; post_head:=null; tt:=vacuous; 16882loop@+ begin t:=cur_tok; link(tail):=t; 16883 if tt<>undefined then 16884 begin @<Find the approximate type |tt| and corresponding~|q|@>; 16885 if tt>=unsuffixed_macro then 16886 @<Either begin an unsuffixed macro call or 16887 prepare for a suffixed one@>; 16888 end; 16889 get_x_next; tail:=t; 16890 if cur_cmd=left_bracket then 16891 @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>; 16892 if cur_cmd>max_suffix_token then goto done1; 16893 if cur_cmd<min_suffix_token then goto done1; 16894 end; {now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token|} 16895done1:@<Handle unusual cases that masquerade as variables, and |goto restart| 16896 or |goto done| if appropriate; 16897 otherwise make a copy of the variable and |goto done|@>; 16898end 16899 16900@ @<Either begin an unsuffixed macro call or...@>= 16901begin link(tail):=null; 16902if tt>unsuffixed_macro then {|tt=suffixed_macro|} 16903 begin post_head:=get_avail; tail:=post_head; link(tail):=t;@/ 16904 tt:=undefined; macro_ref:=value(q); add_mac_ref(macro_ref); 16905 end 16906else @<Set up unsuffixed macro call and |goto restart|@>; 16907end 16908 16909@ @<Scan for a subscript; replace |cur_cmd| by |numeric_token| if found@>= 16910begin get_x_next; scan_expression; 16911if cur_cmd<>right_bracket then 16912 @<Put the left bracket and the expression back to be rescanned@> 16913else begin if cur_type<>known then bad_subscript; 16914 cur_cmd:=numeric_token; cur_mod:=cur_exp; cur_sym:=0; 16915 end; 16916end 16917 16918@ The left bracket that we thought was introducing a subscript might have 16919actually been the left bracket in a mediation construction like `\.{x[a,b]}'. 16920So we don't issue an error message at this point; but we do want to back up 16921so as to avoid any embarrassment about our incorrect assumption. 16922 16923@<Put the left bracket and the expression back to be rescanned@>= 16924begin back_input; {that was the token following the current expression} 16925back_expr; cur_cmd:=left_bracket; cur_mod:=0; cur_sym:=frozen_left_bracket; 16926end 16927 16928@ Here's a routine that puts the current expression back to be read again. 16929 16930@p procedure back_expr; 16931var @!p:pointer; {capsule token} 16932begin p:=stash_cur_exp; link(p):=null; back_list(p); 16933end; 16934 16935@ Unknown subscripts lead to the following error message. 16936 16937@p procedure bad_subscript; 16938begin exp_err("Improper subscript has been replaced by zero"); 16939@.Improper subscript...@> 16940help3("A bracketed subscript must have a known numeric value;")@/ 16941 ("unfortunately, what I found was the value that appears just")@/ 16942 ("above this error message. So I'll try a zero subscript."); 16943flush_error(0); 16944end; 16945 16946@ Every time we call |get_x_next|, there's a chance that the variable we've 16947been looking at will disappear. Thus, we cannot safely keep |q| pointing 16948into the variable structure; we need to start searching from the root each time. 16949 16950@<Find the approximate type |tt| and corresponding~|q|@>= 16951@^inner loop@> 16952begin p:=link(pre_head); q:=info(p); tt:=undefined; 16953if eq_type(q) mod outer_tag=tag_token then 16954 begin q:=equiv(q); 16955 if q=null then goto done2; 16956 loop@+ begin p:=link(p); 16957 if p=null then 16958 begin tt:=type(q); goto done2; 16959 end; 16960 if type(q)<>structured then goto done2; 16961 q:=link(attr_head(q)); {the |collective_subscript| attribute} 16962 if p>=hi_mem_min then {it's not a subscript} 16963 begin repeat q:=link(q); 16964 until attr_loc(q)>=info(p); 16965 if attr_loc(q)>info(p) then goto done2; 16966 end; 16967 end; 16968 end; 16969done2:end 16970 16971@ How do things stand now? Well, we have scanned an entire variable name, 16972including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and 16973|cur_sym| represent the token that follows. If |post_head=null|, a 16974token list for this variable name starts at |link(pre_head)|, with all 16975subscripts evaluated. But if |post_head<>null|, the variable turned out 16976to be a suffixed macro; |pre_head| is the head of the prefix list, while 16977|post_head| is the head of a token list containing both `\.{\AT!}' and 16978the suffix. 16979 16980Our immediate problem is to see if this variable still exists. (Variable 16981structures can change drastically whenever we call |get_x_next|; users 16982aren't supposed to do this, but the fact that it is possible means that 16983we must be cautious.) 16984 16985The following procedure prints an error message when a variable 16986unexpectedly disappears. Its help message isn't quite right for 16987our present purposes, but we'll be able to fix that up. 16988 16989@p procedure obliterated(@!q:pointer); 16990begin print_err("Variable "); show_token_list(q,null,1000,0); 16991print(" has been obliterated"); 16992@.Variable...obliterated@> 16993help5("It seems you did a nasty thing---probably by accident,")@/ 16994 ("but nevertheless you nearly hornswoggled me...")@/ 16995 ("While I was evaluating the right-hand side of this")@/ 16996 ("command, something happened, and the left-hand side")@/ 16997 ("is no longer a variable! So I won't change anything."); 16998end; 16999 17000@ If the variable does exist, we also need to check 17001for a few other special cases before deciding that a plain old ordinary 17002variable has, indeed, been scanned. 17003 17004@<Handle unusual cases that masquerade as variables...@>= 17005if post_head<>null then @<Set up suffixed macro call and |goto restart|@>; 17006q:=link(pre_head); free_avail(pre_head); 17007if cur_cmd=my_var_flag then 17008 begin cur_type:=token_list; cur_exp:=q; goto done; 17009 end; 17010p:=find_variable(q); 17011if p<>null then make_exp_copy(p) 17012else begin obliterated(q);@/ 17013 help_line[2]:="While I was evaluating the suffix of this variable,"; 17014 help_line[1]:="something was redefined, and it's no longer a variable!"; 17015 help_line[0]:="In order to get back on my feet, I've inserted `0' instead."; 17016 put_get_flush_error(0); 17017 end; 17018flush_node_list(q); goto done 17019 17020@ The only complication associated with macro calling is that the prefix 17021and ``at'' parameters must be packaged in an appropriate list of lists. 17022 17023@<Set up unsuffixed macro call and |goto restart|@>= 17024begin p:=get_avail; info(pre_head):=link(pre_head); link(pre_head):=p; 17025info(p):=t; macro_call(value(q),pre_head,null); get_x_next; goto restart; 17026end 17027 17028@ If the ``variable'' that turned out to be a suffixed macro no longer exists, 17029we don't care, because we have reserved a pointer (|macro_ref|) to its 17030token list. 17031 17032@<Set up suffixed macro call and |goto restart|@>= 17033begin back_input; p:=get_avail; q:=link(post_head); 17034info(pre_head):=link(pre_head); link(pre_head):=post_head; 17035info(post_head):=q; link(post_head):=p; info(p):=link(q); link(q):=null; 17036macro_call(macro_ref,pre_head,null); decr(ref_count(macro_ref)); 17037get_x_next; goto restart; 17038end 17039 17040@ Our remaining job is simply to make a copy of the value that has been 17041found. Some cases are harder than others, but complexity arises solely 17042because of the multiplicity of possible cases. 17043 17044@<Declare the procedure called |make_exp_copy|@>= 17045@t\4@>@<Declare subroutines needed by |make_exp_copy|@>@; 17046procedure make_exp_copy(@!p:pointer); 17047label restart; 17048var @!q,@!r,@!t:pointer; {registers for list manipulation} 17049begin restart: cur_type:=type(p); 17050case cur_type of 17051vacuous,boolean_type,known:cur_exp:=value(p); 17052unknown_types:cur_exp:=new_ring_entry(p); 17053string_type:begin cur_exp:=value(p); add_str_ref(cur_exp); 17054 end; 17055pen_type:begin cur_exp:=value(p); add_pen_ref(cur_exp); 17056 end; 17057picture_type:cur_exp:=copy_edges(value(p)); 17058path_type,future_pen:cur_exp:=copy_path(value(p)); 17059transform_type,pair_type:@<Copy the big node |p|@>; 17060dependent,proto_dependent:encapsulate(copy_dep_list(dep_list(p))); 17061numeric_type:begin new_indep(p); goto restart; 17062 end; 17063independent: begin q:=single_dependency(p); 17064 if q=dep_final then 17065 begin cur_type:=known; cur_exp:=0; free_node(q,dep_node_size); 17066 end 17067 else begin cur_type:=dependent; encapsulate(q); 17068 end; 17069 end; 17070othercases confusion("copy") 17071@:this can't happen copy}{\quad copy@> 17072endcases; 17073end; 17074 17075@ The |encapsulate| subroutine assumes that |dep_final| is the 17076tail of dependency list~|p|. 17077 17078@<Declare subroutines needed by |make_exp_copy|@>= 17079procedure encapsulate(@!p:pointer); 17080begin cur_exp:=get_node(value_node_size); type(cur_exp):=cur_type; 17081name_type(cur_exp):=capsule; new_dep(cur_exp,p); 17082end; 17083 17084@ The most tedious case arises when the user refers to a 17085\&{pair} or \&{transform} variable; we must copy several fields, 17086each of which can be |independent|, |dependent|, |proto_dependent|, 17087or |known|. 17088 17089@<Copy the big node |p|@>= 17090begin if value(p)=null then init_big_node(p); 17091t:=get_node(value_node_size); name_type(t):=capsule; type(t):=cur_type; 17092init_big_node(t);@/ 17093q:=value(p)+big_node_size[cur_type]; r:=value(t)+big_node_size[cur_type]; 17094repeat q:=q-2; r:=r-2; install(r,q); 17095until q=value(p); 17096cur_exp:=t; 17097end 17098 17099@ The |install| procedure copies a numeric field~|q| into field~|r| of 17100a big node that will be part of a capsule. 17101 17102@<Declare subroutines needed by |make_exp_copy|@>= 17103procedure install(@!r,@!q:pointer); 17104var p:pointer; {temporary register} 17105begin if type(q)=known then 17106 begin value(r):=value(q); type(r):=known; 17107 end 17108else if type(q)=independent then 17109 begin p:=single_dependency(q); 17110 if p=dep_final then 17111 begin type(r):=known; value(r):=0; free_node(p,dep_node_size); 17112 end 17113 else begin type(r):=dependent; new_dep(r,p); 17114 end; 17115 end 17116 else begin type(r):=type(q); new_dep(r,copy_dep_list(dep_list(q))); 17117 end; 17118end; 17119 17120@ Expressions of the form `\.{a[b,c]}' are converted into 17121`\.{b+a*(c-b)}', without checking the types of \.b~or~\.c, 17122provided that \.a is numeric. 17123 17124@<Scan a mediation...@>= 17125begin p:=stash_cur_exp; get_x_next; scan_expression; 17126if cur_cmd<>comma then 17127 begin @<Put the left bracket and the expression back...@>; 17128 unstash_cur_exp(p); 17129 end 17130else begin q:=stash_cur_exp; get_x_next; scan_expression; 17131 if cur_cmd<>right_bracket then 17132 begin missing_err("]");@/ 17133@.Missing `]'@> 17134 help3("I've scanned an expression of the form `a[b,c',")@/ 17135 ("so a right bracket should have come next.")@/ 17136 ("I shall pretend that one was there.");@/ 17137 back_error; 17138 end; 17139 r:=stash_cur_exp; make_exp_copy(q);@/ 17140 do_binary(r,minus); do_binary(p,times); do_binary(q,plus); get_x_next; 17141 end; 17142end 17143 17144@ Here is a comparatively simple routine that is used to scan the 17145\&{suffix} parameters of a macro. 17146 17147@<Declare the basic parsing subroutines@>= 17148procedure scan_suffix; 17149label done; 17150var @!h,@!t:pointer; {head and tail of the list being built} 17151@!p:pointer; {temporary register} 17152begin h:=get_avail; t:=h; 17153loop@+ begin if cur_cmd=left_bracket then 17154 @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>; 17155 if cur_cmd=numeric_token then p:=new_num_tok(cur_mod) 17156 else if (cur_cmd=tag_token)or(cur_cmd=internal_quantity) then 17157 begin p:=get_avail; info(p):=cur_sym; 17158 end 17159 else goto done; 17160 link(t):=p; t:=p; get_x_next; 17161 end; 17162done: cur_exp:=link(h); free_avail(h); cur_type:=token_list; 17163end; 17164 17165@ @<Scan a bracketed subscript and set |cur_cmd:=numeric_token|@>= 17166begin get_x_next; scan_expression; 17167if cur_type<>known then bad_subscript; 17168if cur_cmd<>right_bracket then 17169 begin missing_err("]");@/ 17170@.Missing `]'@> 17171 help3("I've seen a `[' and a subscript value, in a suffix,")@/ 17172 ("so a right bracket should have come next.")@/ 17173 ("I shall pretend that one was there.");@/ 17174 back_error; 17175 end; 17176cur_cmd:=numeric_token; cur_mod:=cur_exp; 17177end 17178 17179@* \[41] Parsing secondary and higher expressions. 17180After the intricacies of |scan_primary|\kern-1pt, 17181the |scan_secondary| routine is 17182refreshingly simple. It's not trivial, but the operations are relatively 17183straightforward; the main difficulty is, again, that expressions and data 17184structures might change drastically every time we call |get_x_next|, so a 17185cautious approach is mandatory. For example, a macro defined by 17186\&{primarydef} might have disappeared by the time its second argument has 17187been scanned; we solve this by increasing the reference count of its token 17188list, so that the macro can be called even after it has been clobbered. 17189 17190@<Declare the basic parsing subroutines@>= 17191procedure scan_secondary; 17192label restart,continue; 17193var @!p:pointer; {for list manipulation} 17194@!c,@!d:halfword; {operation codes or modifiers} 17195@!mac_name:pointer; {token defined with \&{primarydef}} 17196begin restart:if(cur_cmd<min_primary_command)or@| 17197 (cur_cmd>max_primary_command) then 17198 bad_exp("A secondary"); 17199@.A secondary expression...@> 17200scan_primary; 17201continue: if cur_cmd<=max_secondary_command then 17202 if cur_cmd>=min_secondary_command then 17203 begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd; 17204 if d=secondary_primary_macro then 17205 begin mac_name:=cur_sym; add_mac_ref(c); 17206 end; 17207 get_x_next; scan_primary; 17208 if d<>secondary_primary_macro then do_binary(p,c) 17209 else begin back_input; binary_mac(p,c,mac_name); 17210 decr(ref_count(c)); get_x_next; goto restart; 17211 end; 17212 goto continue; 17213 end; 17214end; 17215 17216@ The following procedure calls a macro that has two parameters, 17217|p| and |cur_exp|. 17218 17219@p procedure binary_mac(@!p,@!c,@!n:pointer); 17220var @!q,@!r:pointer; {nodes in the parameter list} 17221begin q:=get_avail; r:=get_avail; link(q):=r;@/ 17222info(q):=p; info(r):=stash_cur_exp;@/ 17223macro_call(c,q,n); 17224end; 17225 17226@ The next procedure, |scan_tertiary|, is pretty much the same deal. 17227 17228@<Declare the basic parsing subroutines@>= 17229procedure scan_tertiary; 17230label restart,continue; 17231var @!p:pointer; {for list manipulation} 17232@!c,@!d:halfword; {operation codes or modifiers} 17233@!mac_name:pointer; {token defined with \&{secondarydef}} 17234begin restart:if(cur_cmd<min_primary_command)or@| 17235 (cur_cmd>max_primary_command) then 17236 bad_exp("A tertiary"); 17237@.A tertiary expression...@> 17238scan_secondary; 17239if cur_type=future_pen then materialize_pen; 17240continue: if cur_cmd<=max_tertiary_command then 17241 if cur_cmd>=min_tertiary_command then 17242 begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd; 17243 if d=tertiary_secondary_macro then 17244 begin mac_name:=cur_sym; add_mac_ref(c); 17245 end; 17246 get_x_next; scan_secondary; 17247 if d<>tertiary_secondary_macro then do_binary(p,c) 17248 else begin back_input; binary_mac(p,c,mac_name); 17249 decr(ref_count(c)); get_x_next; goto restart; 17250 end; 17251 goto continue; 17252 end; 17253end; 17254 17255@ A |future_pen| becomes a full-fledged pen here. 17256 17257@p procedure materialize_pen; 17258label common_ending; 17259var @!a_minus_b,@!a_plus_b,@!major_axis,@!minor_axis:scaled; {ellipse variables} 17260@!theta:angle; {amount by which the ellipse has been rotated} 17261@!p:pointer; {path traverser} 17262@!q:pointer; {the knot list to be made into a pen} 17263begin q:=cur_exp; 17264if left_type(q)=endpoint then 17265 begin print_err("Pen path must be a cycle"); 17266@.Pen path must be a cycle@> 17267 help2("I can't make a pen from the given path.")@/ 17268 ("So I've replaced it by the trivial path `(0,0)..cycle'."); 17269 put_get_error; cur_exp:=null_pen; goto common_ending; 17270 end 17271else if left_type(q)=open then 17272 @<Change node |q| to a path for an elliptical pen@>; 17273cur_exp:=make_pen(q); 17274common_ending: toss_knot_list(q); cur_type:=pen_type; 17275end; 17276 17277@ We placed the three points $(0,0)$, $(1,0)$, $(0,1)$ into a \&{pencircle}, 17278and they have now been transformed to $(u,v)$, $(A+u,B+v)$, $(C+u,D+v)$; 17279this gives us enough information to deduce the transformation 17280$(x,y)\mapsto(Ax+Cy+u,Bx+Dy+v)$. 17281 17282Given ($A,B,C,D)$ we can always find $(a,b,\theta,\phi)$ such that 17283$$\eqalign{A&=a\cos\phi\cos\theta-b\sin\phi\sin\theta;\cr 17284B&=a\cos\phi\sin\theta+b\sin\phi\cos\theta;\cr 17285C&=-a\sin\phi\cos\theta-b\cos\phi\sin\theta;\cr 17286D&=-a\sin\phi\sin\theta+b\cos\phi\cos\theta.\cr}$$ 17287In this notation, the unit circle $(\cos t,\sin t)$ is transformed into 17288$$\bigl(a\cos(\phi+t)\cos\theta-b\sin(\phi+t)\sin\theta,\; 17289a\cos(\phi+t)\sin\theta+b\sin(\phi+t)\cos\theta\bigr)\;+\;(u,v),$$ 17290which is an ellipse with semi-axes~$(a,b)$, rotated by~$\theta$ and 17291shifted by~$(u,v)$. To solve the stated equations, we note that it is 17292necessary and sufficient to solve 17293$$\eqalign{A-D&=(a-b)\cos(\theta-\phi),\cr 17294B+C&=(a-b)\sin(\theta-\phi),\cr} 17295\qquad 17296\eqalign{A+D&=(a+b)\cos(\theta+\phi),\cr 17297B-C&=(a+b)\sin(\theta+\phi);\cr}$$ 17298and it is easy to find $a-b$, $a+b$, $\theta-\phi$, and $\theta+\phi$ 17299from these formulas. 17300 17301The code below uses |(txx,tyx,txy,tyy,tx,ty)| to stand for 17302$(A,B,C,D,u,v)$. 17303 17304@<Change node |q|...@>= 17305begin tx:=x_coord(q); ty:=y_coord(q); 17306txx:=left_x(q)-tx; tyx:=left_y(q)-ty; 17307txy:=right_x(q)-tx; tyy:=right_y(q)-ty; 17308a_minus_b:=pyth_add(txx-tyy,tyx+txy); a_plus_b:=pyth_add(txx+tyy,tyx-txy); 17309major_axis:=half(a_minus_b+a_plus_b); minor_axis:=half(abs(a_plus_b-a_minus_b)); 17310if major_axis=minor_axis then theta:=0 {circle} 17311else theta:=half(n_arg(txx-tyy,tyx+txy)+n_arg(txx+tyy,tyx-txy)); 17312free_node(q,knot_node_size); 17313q:=make_ellipse(major_axis,minor_axis,theta); 17314if (tx<>0)or(ty<>0) then @<Shift the coordinates of path |q|@>; 17315end 17316 17317@ @<Shift the coordinates of path |q|@>= 17318begin p:=q; 17319repeat x_coord(p):=x_coord(p)+tx; y_coord(p):=y_coord(p)+ty; p:=link(p); 17320until p=q; 17321end 17322 17323@ Finally we reach the deepest level in our quartet of parsing routines. 17324This one is much like the others; but it has an extra complication from 17325paths, which materialize here. 17326 17327@d continue_path=25 {a label inside of |scan_expression|} 17328@d finish_path=26 {another} 17329 17330@<Declare the basic parsing subroutines@>= 17331procedure scan_expression; 17332label restart,done,continue,continue_path,finish_path,exit; 17333var @!p,@!q,@!r,@!pp,@!qq:pointer; {for list manipulation} 17334@!c,@!d:halfword; {operation codes or modifiers} 17335@!my_var_flag:0..max_command_code; {initial value of |var_flag|} 17336@!mac_name:pointer; {token defined with \&{tertiarydef}} 17337@!cycle_hit:boolean; {did a path expression just end with `\&{cycle}'?} 17338@!x,@!y:scaled; {explicit coordinates or tension at a path join} 17339@!t:endpoint..open; {knot type following a path join} 17340begin my_var_flag:=var_flag; 17341restart:if(cur_cmd<min_primary_command)or@| 17342 (cur_cmd>max_primary_command) then 17343 bad_exp("An"); 17344@.An expression...@> 17345scan_tertiary; 17346continue: if cur_cmd<=max_expression_command then 17347 if cur_cmd>=min_expression_command then 17348 if (cur_cmd<>equals)or(my_var_flag<>assignment) then 17349 begin p:=stash_cur_exp; c:=cur_mod; d:=cur_cmd; 17350 if d=expression_tertiary_macro then 17351 begin mac_name:=cur_sym; add_mac_ref(c); 17352 end; 17353 if (d<ampersand)or((d=ampersand)and@| 17354 ((type(p)=pair_type)or(type(p)=path_type))) then 17355 @<Scan a path construction operation; 17356 but |return| if |p| has the wrong type@> 17357 else begin get_x_next; scan_tertiary; 17358 if d<>expression_tertiary_macro then do_binary(p,c) 17359 else begin back_input; binary_mac(p,c,mac_name); 17360 decr(ref_count(c)); get_x_next; goto restart; 17361 end; 17362 end; 17363 goto continue; 17364 end; 17365exit:end; 17366 17367@ The reader should review the data structure conventions for paths before 17368hoping to understand the next part of this code. 17369 17370@<Scan a path construction operation...@>= 17371begin cycle_hit:=false; 17372@<Convert the left operand, |p|, into a partial path ending at~|q|; 17373 but |return| if |p| doesn't have a suitable type@>; 17374continue_path: @<Determine the path join parameters; 17375 but |goto finish_path| if there's only a direction specifier@>; 17376if cur_cmd=cycle then @<Get ready to close a cycle@> 17377else begin scan_tertiary; 17378 @<Convert the right operand, |cur_exp|, 17379 into a partial path from |pp| to~|qq|@>; 17380 end; 17381@<Join the partial paths and reset |p| and |q| to the head and tail 17382 of the result@>; 17383if cur_cmd>=min_expression_command then 17384 if cur_cmd<=ampersand then if not cycle_hit then goto continue_path; 17385finish_path: 17386@<Choose control points for the path and put the result into |cur_exp|@>; 17387end 17388 17389@ @<Convert the left operand, |p|, into a partial path ending at~|q|...@>= 17390begin unstash_cur_exp(p); 17391if cur_type=pair_type then p:=new_knot 17392else if cur_type=path_type then p:=cur_exp 17393else return; 17394q:=p; 17395while link(q)<>p do q:=link(q); 17396if left_type(p)<>endpoint then {open up a cycle} 17397 begin r:=copy_knot(p); link(q):=r; q:=r; 17398 end; 17399left_type(p):=open; right_type(q):=open; 17400end 17401 17402@ A pair of numeric values is changed into a knot node for a one-point path 17403when \MF\ discovers that the pair is part of a path. 17404 17405@p@t\4@>@<Declare the procedure called |known_pair|@>@; 17406function new_knot:pointer; {convert a pair to a knot with two endpoints} 17407var @!q:pointer; {the new node} 17408begin q:=get_node(knot_node_size); left_type(q):=endpoint; 17409right_type(q):=endpoint; link(q):=q;@/ 17410known_pair; x_coord(q):=cur_x; y_coord(q):=cur_y; 17411new_knot:=q; 17412end; 17413 17414@ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components 17415of the current expression, assuming that the current expression is a 17416pair of known numerics. Unknown components are zeroed, and the 17417current expression is flushed. 17418 17419@<Declare the procedure called |known_pair|@>= 17420procedure known_pair; 17421var @!p:pointer; {the pair node} 17422begin if cur_type<>pair_type then 17423 begin exp_err("Undefined coordinates have been replaced by (0,0)"); 17424@.Undefined coordinates...@> 17425 help5("I need x and y numbers for this part of the path.")@/ 17426 ("The value I found (see above) was no good;")@/ 17427 ("so I'll try to keep going by using zero instead.")@/ 17428 ("(Chapter 27 of The METAFONTbook explains that")@/ 17429@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 17430 ("you might want to type `I ???' now.)"); 17431 put_get_flush_error(0); cur_x:=0; cur_y:=0; 17432 end 17433else begin p:=value(cur_exp); 17434 @<Make sure that both |x| and |y| parts of |p| are known; 17435 copy them into |cur_x| and |cur_y|@>; 17436 flush_cur_exp(0); 17437 end; 17438end; 17439 17440@ @<Make sure that both |x| and |y| parts of |p| are known...@>= 17441if type(x_part_loc(p))=known then cur_x:=value(x_part_loc(p)) 17442else begin disp_err(x_part_loc(p), 17443 "Undefined x coordinate has been replaced by 0"); 17444@.Undefined coordinates...@> 17445 help5("I need a `known' x value for this part of the path.")@/ 17446 ("The value I found (see above) was no good;")@/ 17447 ("so I'll try to keep going by using zero instead.")@/ 17448 ("(Chapter 27 of The METAFONTbook explains that")@/ 17449@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 17450 ("you might want to type `I ???' now.)"); 17451 put_get_error; recycle_value(x_part_loc(p)); cur_x:=0; 17452 end; 17453if type(y_part_loc(p))=known then cur_y:=value(y_part_loc(p)) 17454else begin disp_err(y_part_loc(p), 17455 "Undefined y coordinate has been replaced by 0"); 17456 help5("I need a `known' y value for this part of the path.")@/ 17457 ("The value I found (see above) was no good;")@/ 17458 ("so I'll try to keep going by using zero instead.")@/ 17459 ("(Chapter 27 of The METAFONTbook explains that")@/ 17460 ("you might want to type `I ???' now.)"); 17461 put_get_error; recycle_value(y_part_loc(p)); cur_y:=0; 17462 end 17463 17464@ At this point |cur_cmd| is either |ampersand|, |left_brace|, or |path_join|. 17465 17466@<Determine the path join parameters...@>= 17467if cur_cmd=left_brace then 17468 @<Put the pre-join direction information into node |q|@>; 17469d:=cur_cmd; 17470if d=path_join then @<Determine the tension and/or control points@> 17471else if d<>ampersand then goto finish_path; 17472get_x_next; 17473if cur_cmd=left_brace then 17474 @<Put the post-join direction information into |x| and |t|@> 17475else if right_type(q)<>explicit then 17476 begin t:=open; x:=0; 17477 end 17478 17479@ The |scan_direction| subroutine looks at the directional information 17480that is enclosed in braces, and also scans ahead to the following character. 17481A type code is returned, either |open| (if the direction was $(0,0)$), 17482or |curl| (if the direction was a curl of known value |cur_exp|), or 17483|given| (if the direction is given by the |angle| value that now 17484appears in |cur_exp|). 17485 17486There's nothing difficult about this subroutine, but the program is rather 17487lengthy because a variety of potential errors need to be nipped in the bud. 17488 17489@p function scan_direction:small_number; 17490var @!t:given..open; {the type of information found} 17491@!x:scaled; {an |x| coordinate} 17492begin get_x_next; 17493if cur_cmd=curl_command then @<Scan a curl specification@> 17494else @<Scan a given direction@>; 17495if cur_cmd<>right_brace then 17496 begin missing_err("}");@/ 17497@.Missing `\char`\}'@> 17498 help3("I've scanned a direction spec for part of a path,")@/ 17499 ("so a right brace should have come next.")@/ 17500 ("I shall pretend that one was there.");@/ 17501 back_error; 17502 end; 17503get_x_next; scan_direction:=t; 17504end; 17505 17506@ @<Scan a curl specification@>= 17507begin get_x_next; scan_expression; 17508if (cur_type<>known)or(cur_exp<0) then 17509 begin exp_err("Improper curl has been replaced by 1"); 17510@.Improper curl@> 17511 help1("A curl must be a known, nonnegative number."); 17512 put_get_flush_error(unity); 17513 end; 17514t:=curl; 17515end 17516 17517@ @<Scan a given direction@>= 17518begin scan_expression; 17519if cur_type>pair_type then @<Get given directions separated by commas@> 17520else known_pair; 17521if (cur_x=0)and(cur_y=0) then t:=open 17522else begin t:=given; cur_exp:=n_arg(cur_x,cur_y); 17523 end; 17524end 17525 17526@ @<Get given directions separated by commas@>= 17527begin if cur_type<>known then 17528 begin exp_err("Undefined x coordinate has been replaced by 0"); 17529@.Undefined coordinates...@> 17530 help5("I need a `known' x value for this part of the path.")@/ 17531 ("The value I found (see above) was no good;")@/ 17532 ("so I'll try to keep going by using zero instead.")@/ 17533 ("(Chapter 27 of The METAFONTbook explains that")@/ 17534@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 17535 ("you might want to type `I ???' now.)"); 17536 put_get_flush_error(0); 17537 end; 17538x:=cur_exp; 17539if cur_cmd<>comma then 17540 begin missing_err(",");@/ 17541@.Missing `,'@> 17542 help2("I've got the x coordinate of a path direction;")@/ 17543 ("will look for the y coordinate next."); 17544 back_error; 17545 end; 17546get_x_next; scan_expression; 17547if cur_type<>known then 17548 begin exp_err("Undefined y coordinate has been replaced by 0"); 17549 help5("I need a `known' y value for this part of the path.")@/ 17550 ("The value I found (see above) was no good;")@/ 17551 ("so I'll try to keep going by using zero instead.")@/ 17552 ("(Chapter 27 of The METAFONTbook explains that")@/ 17553 ("you might want to type `I ???' now.)"); 17554 put_get_flush_error(0); 17555 end; 17556cur_y:=cur_exp; cur_x:=x; 17557end 17558 17559@ At this point |right_type(q)| is usually |open|, but it may have been 17560set to some other value by a previous operation. We must maintain 17561the value of |right_type(q)| in cases such as 17562`\.{..\{curl2\}z\{0,0\}..}'. 17563 17564@<Put the pre-join...@>= 17565begin t:=scan_direction; 17566if t<>open then 17567 begin right_type(q):=t; right_given(q):=cur_exp; 17568 if left_type(q)=open then 17569 begin left_type(q):=t; left_given(q):=cur_exp; 17570 end; {note that |left_given(q)=left_curl(q)|} 17571 end; 17572end 17573 17574@ Since |left_tension| and |left_y| share the same position in knot nodes, 17575and since |left_given| is similarly equivalent to |left_x|, we use 17576|x| and |y| to hold the given direction and tension information when 17577there are no explicit control points. 17578 17579@<Put the post-join...@>= 17580begin t:=scan_direction; 17581if right_type(q)<>explicit then x:=cur_exp 17582else t:=explicit; {the direction information is superfluous} 17583end 17584 17585@ @<Determine the tension and/or...@>= 17586begin get_x_next; 17587if cur_cmd=tension then @<Set explicit tensions@> 17588else if cur_cmd=controls then @<Set explicit control points@> 17589else begin right_tension(q):=unity; y:=unity; back_input; {default tension} 17590 goto done; 17591 end; 17592if cur_cmd<>path_join then 17593 begin missing_err("..");@/ 17594@.Missing `..'@> 17595 help1("A path join command should end with two dots."); 17596 back_error; 17597 end; 17598done:end 17599 17600@ @<Set explicit tensions@>= 17601begin get_x_next; y:=cur_cmd; 17602if cur_cmd=at_least then get_x_next; 17603scan_primary; 17604@<Make sure that the current expression is a valid tension setting@>; 17605if y=at_least then negate(cur_exp); 17606right_tension(q):=cur_exp; 17607if cur_cmd=and_command then 17608 begin get_x_next; y:=cur_cmd; 17609 if cur_cmd=at_least then get_x_next; 17610 scan_primary; 17611 @<Make sure that the current expression is a valid tension setting@>; 17612 if y=at_least then negate(cur_exp); 17613 end; 17614y:=cur_exp; 17615end 17616 17617@ @d min_tension==three_quarter_unit 17618 17619@<Make sure that the current expression is a valid tension setting@>= 17620if (cur_type<>known)or(cur_exp<min_tension) then 17621 begin exp_err("Improper tension has been set to 1"); 17622@.Improper tension@> 17623 help1("The expression above should have been a number >=3/4."); 17624 put_get_flush_error(unity); 17625 end 17626 17627@ @<Set explicit control points@>= 17628begin right_type(q):=explicit; t:=explicit; get_x_next; scan_primary;@/ 17629known_pair; right_x(q):=cur_x; right_y(q):=cur_y; 17630if cur_cmd<>and_command then 17631 begin x:=right_x(q); y:=right_y(q); 17632 end 17633else begin get_x_next; scan_primary;@/ 17634 known_pair; x:=cur_x; y:=cur_y; 17635 end; 17636end 17637 17638@ @<Convert the right operand, |cur_exp|, into a partial path...@>= 17639begin if cur_type<>path_type then pp:=new_knot 17640else pp:=cur_exp; 17641qq:=pp; 17642while link(qq)<>pp do qq:=link(qq); 17643if left_type(pp)<>endpoint then {open up a cycle} 17644 begin r:=copy_knot(pp); link(qq):=r; qq:=r; 17645 end; 17646left_type(pp):=open; right_type(qq):=open; 17647end 17648 17649@ If a person tries to define an entire path by saying `\.{(x,y)\&cycle}', 17650we silently change the specification to `\.{(x,y)..cycle}', since a cycle 17651shouldn't have length zero. 17652 17653@<Get ready to close a cycle@>= 17654begin cycle_hit:=true; get_x_next; pp:=p; qq:=p; 17655if d=ampersand then if p=q then 17656 begin d:=path_join; right_tension(q):=unity; y:=unity; 17657 end; 17658end 17659 17660@ @<Join the partial paths and reset |p| and |q|...@>= 17661begin if d=ampersand then 17662 if (x_coord(q)<>x_coord(pp))or(y_coord(q)<>y_coord(pp)) then 17663 begin print_err("Paths don't touch; `&' will be changed to `..'"); 17664@.Paths don't touch@> 17665 help3("When you join paths `p&q', the ending point of p")@/ 17666 ("must be exactly equal to the starting point of q.")@/ 17667 ("So I'm going to pretend that you said `p..q' instead."); 17668 put_get_error; d:=path_join; right_tension(q):=unity; y:=unity; 17669 end; 17670@<Plug an opening in |right_type(pp)|, if possible@>; 17671if d=ampersand then @<Splice independent paths together@> 17672else begin @<Plug an opening in |right_type(q)|, if possible@>; 17673 link(q):=pp; left_y(pp):=y; 17674 if t<>open then 17675 begin left_x(pp):=x; left_type(pp):=t; 17676 end; 17677 end; 17678q:=qq; 17679end 17680 17681@ @<Plug an opening in |right_type(q)|...@>= 17682if right_type(q)=open then 17683 if (left_type(q)=curl)or(left_type(q)=given) then 17684 begin right_type(q):=left_type(q); right_given(q):=left_given(q); 17685 end 17686 17687@ @<Plug an opening in |right_type(pp)|...@>= 17688if right_type(pp)=open then 17689 if (t=curl)or(t=given) then 17690 begin right_type(pp):=t; right_given(pp):=x; 17691 end 17692 17693@ @<Splice independent paths together@>= 17694begin if left_type(q)=open then if right_type(q)=open then 17695 begin left_type(q):=curl; left_curl(q):=unity; 17696 end; 17697if right_type(pp)=open then if t=open then 17698 begin right_type(pp):=curl; right_curl(pp):=unity; 17699 end; 17700right_type(q):=right_type(pp); link(q):=link(pp);@/ 17701right_x(q):=right_x(pp); right_y(q):=right_y(pp); 17702free_node(pp,knot_node_size); 17703if qq=pp then qq:=q; 17704end 17705 17706@ @<Choose control points for the path...@>= 17707if cycle_hit then 17708 begin if d=ampersand then p:=q; 17709 end 17710else begin left_type(p):=endpoint; 17711 if right_type(p)=open then 17712 begin right_type(p):=curl; right_curl(p):=unity; 17713 end; 17714 right_type(q):=endpoint; 17715 if left_type(q)=open then 17716 begin left_type(q):=curl; left_curl(q):=unity; 17717 end; 17718 link(q):=p; 17719 end; 17720make_choices(p); 17721cur_type:=path_type; cur_exp:=p 17722 17723@ Finally, we sometimes need to scan an expression whose value is 17724supposed to be either |true_code| or |false_code|. 17725 17726@<Declare the basic parsing subroutines@>= 17727procedure get_boolean; 17728begin get_x_next; scan_expression; 17729if cur_type<>boolean_type then 17730 begin exp_err("Undefined condition will be treated as `false'"); 17731@.Undefined condition...@> 17732 help2("The expression shown above should have had a definite")@/ 17733 ("true-or-false value. I'm changing it to `false'.");@/ 17734 put_get_flush_error(false_code); cur_type:=boolean_type; 17735 end; 17736end; 17737 17738@* \[42] Doing the operations. 17739The purpose of parsing is primarily to permit people to avoid piles of 17740parentheses. But the real work is done after the structure of an expression 17741has been recognized; that's when new expressions are generated. We 17742turn now to the guts of \MF, which handles individual operators that 17743have come through the parsing mechanism. 17744 17745We'll start with the easy ones that take no operands, then work our way 17746up to operators with one and ultimately two arguments. In other words, 17747we will write the three procedures |do_nullary|, |do_unary|, and |do_binary| 17748that are invoked periodically by the expression scanners. 17749 17750First let's make sure that all of the primitive operators are in the 17751hash table. Although |scan_primary| and its relatives made use of the 17752\\{cmd} code for these operators, the \\{do} routines base everything 17753on the \\{mod} code. For example, |do_binary| doesn't care whether the 17754operation it performs is a |primary_binary| or |secondary_binary|, etc. 17755 17756@<Put each...@>= 17757primitive("true",nullary,true_code);@/ 17758@!@:true_}{\&{true} primitive@> 17759primitive("false",nullary,false_code);@/ 17760@!@:false_}{\&{false} primitive@> 17761primitive("nullpicture",nullary,null_picture_code);@/ 17762@!@:null_picture_}{\&{nullpicture} primitive@> 17763primitive("nullpen",nullary,null_pen_code);@/ 17764@!@:null_pen_}{\&{nullpen} primitive@> 17765primitive("jobname",nullary,job_name_op);@/ 17766@!@:job_name_}{\&{jobname} primitive@> 17767primitive("readstring",nullary,read_string_op);@/ 17768@!@:read_string_}{\&{readstring} primitive@> 17769primitive("pencircle",nullary,pen_circle);@/ 17770@!@:pen_circle_}{\&{pencircle} primitive@> 17771primitive("normaldeviate",nullary,normal_deviate);@/ 17772@!@:normal_deviate_}{\&{normaldeviate} primitive@> 17773primitive("odd",unary,odd_op);@/ 17774@!@:odd_}{\&{odd} primitive@> 17775primitive("known",unary,known_op);@/ 17776@!@:known_}{\&{known} primitive@> 17777primitive("unknown",unary,unknown_op);@/ 17778@!@:unknown_}{\&{unknown} primitive@> 17779primitive("not",unary,not_op);@/ 17780@!@:not_}{\&{not} primitive@> 17781primitive("decimal",unary,decimal);@/ 17782@!@:decimal_}{\&{decimal} primitive@> 17783primitive("reverse",unary,reverse);@/ 17784@!@:reverse_}{\&{reverse} primitive@> 17785primitive("makepath",unary,make_path_op);@/ 17786@!@:make_path_}{\&{makepath} primitive@> 17787primitive("makepen",unary,make_pen_op);@/ 17788@!@:make_pen_}{\&{makepen} primitive@> 17789primitive("totalweight",unary,total_weight_op);@/ 17790@!@:total_weight_}{\&{totalweight} primitive@> 17791primitive("oct",unary,oct_op);@/ 17792@!@:oct_}{\&{oct} primitive@> 17793primitive("hex",unary,hex_op);@/ 17794@!@:hex_}{\&{hex} primitive@> 17795primitive("ASCII",unary,ASCII_op);@/ 17796@!@:ASCII_}{\&{ASCII} primitive@> 17797primitive("char",unary,char_op);@/ 17798@!@:char_}{\&{char} primitive@> 17799primitive("length",unary,length_op);@/ 17800@!@:length_}{\&{length} primitive@> 17801primitive("turningnumber",unary,turning_op);@/ 17802@!@:turning_number_}{\&{turningnumber} primitive@> 17803primitive("xpart",unary,x_part);@/ 17804@!@:x_part_}{\&{xpart} primitive@> 17805primitive("ypart",unary,y_part);@/ 17806@!@:y_part_}{\&{ypart} primitive@> 17807primitive("xxpart",unary,xx_part);@/ 17808@!@:xx_part_}{\&{xxpart} primitive@> 17809primitive("xypart",unary,xy_part);@/ 17810@!@:xy_part_}{\&{xypart} primitive@> 17811primitive("yxpart",unary,yx_part);@/ 17812@!@:yx_part_}{\&{yxpart} primitive@> 17813primitive("yypart",unary,yy_part);@/ 17814@!@:yy_part_}{\&{yypart} primitive@> 17815primitive("sqrt",unary,sqrt_op);@/ 17816@!@:sqrt_}{\&{sqrt} primitive@> 17817primitive("mexp",unary,m_exp_op);@/ 17818@!@:m_exp_}{\&{mexp} primitive@> 17819primitive("mlog",unary,m_log_op);@/ 17820@!@:m_log_}{\&{mlog} primitive@> 17821primitive("sind",unary,sin_d_op);@/ 17822@!@:sin_d_}{\&{sind} primitive@> 17823primitive("cosd",unary,cos_d_op);@/ 17824@!@:cos_d_}{\&{cosd} primitive@> 17825primitive("floor",unary,floor_op);@/ 17826@!@:floor_}{\&{floor} primitive@> 17827primitive("uniformdeviate",unary,uniform_deviate);@/ 17828@!@:uniform_deviate_}{\&{uniformdeviate} primitive@> 17829primitive("charexists",unary,char_exists_op);@/ 17830@!@:char_exists_}{\&{charexists} primitive@> 17831primitive("angle",unary,angle_op);@/ 17832@!@:angle_}{\&{angle} primitive@> 17833primitive("cycle",cycle,cycle_op);@/ 17834@!@:cycle_}{\&{cycle} primitive@> 17835primitive("+",plus_or_minus,plus);@/ 17836@!@:+ }{\.{+} primitive@> 17837primitive("-",plus_or_minus,minus);@/ 17838@!@:- }{\.{-} primitive@> 17839primitive("*",secondary_binary,times);@/ 17840@!@:* }{\.{*} primitive@> 17841primitive("/",slash,over); eqtb[frozen_slash]:=eqtb[cur_sym];@/ 17842@!@:/ }{\.{/} primitive@> 17843primitive("++",tertiary_binary,pythag_add);@/ 17844@!@:++_}{\.{++} primitive@> 17845primitive("+-+",tertiary_binary,pythag_sub);@/ 17846@!@:+-+_}{\.{+-+} primitive@> 17847primitive("and",and_command,and_op);@/ 17848@!@:and_}{\&{and} primitive@> 17849primitive("or",tertiary_binary,or_op);@/ 17850@!@:or_}{\&{or} primitive@> 17851primitive("<",expression_binary,less_than);@/ 17852@!@:< }{\.{<} primitive@> 17853primitive("<=",expression_binary,less_or_equal);@/ 17854@!@:<=_}{\.{<=} primitive@> 17855primitive(">",expression_binary,greater_than);@/ 17856@!@:> }{\.{>} primitive@> 17857primitive(">=",expression_binary,greater_or_equal);@/ 17858@!@:>=_}{\.{>=} primitive@> 17859primitive("=",equals,equal_to);@/ 17860@!@:= }{\.{=} primitive@> 17861primitive("<>",expression_binary,unequal_to);@/ 17862@!@:<>_}{\.{<>} primitive@> 17863primitive("substring",primary_binary,substring_of);@/ 17864@!@:substring_}{\&{substring} primitive@> 17865primitive("subpath",primary_binary,subpath_of);@/ 17866@!@:subpath_}{\&{subpath} primitive@> 17867primitive("directiontime",primary_binary,direction_time_of);@/ 17868@!@:direction_time_}{\&{directiontime} primitive@> 17869primitive("point",primary_binary,point_of);@/ 17870@!@:point_}{\&{point} primitive@> 17871primitive("precontrol",primary_binary,precontrol_of);@/ 17872@!@:precontrol_}{\&{precontrol} primitive@> 17873primitive("postcontrol",primary_binary,postcontrol_of);@/ 17874@!@:postcontrol_}{\&{postcontrol} primitive@> 17875primitive("penoffset",primary_binary,pen_offset_of);@/ 17876@!@:pen_offset_}{\&{penoffset} primitive@> 17877primitive("&",ampersand,concatenate);@/ 17878@!@:!!!}{\.{\&} primitive@> 17879primitive("rotated",secondary_binary,rotated_by);@/ 17880@!@:rotated_}{\&{rotated} primitive@> 17881primitive("slanted",secondary_binary,slanted_by);@/ 17882@!@:slanted_}{\&{slanted} primitive@> 17883primitive("scaled",secondary_binary,scaled_by);@/ 17884@!@:scaled_}{\&{scaled} primitive@> 17885primitive("shifted",secondary_binary,shifted_by);@/ 17886@!@:shifted_}{\&{shifted} primitive@> 17887primitive("transformed",secondary_binary,transformed_by);@/ 17888@!@:transformed_}{\&{transformed} primitive@> 17889primitive("xscaled",secondary_binary,x_scaled);@/ 17890@!@:x_scaled_}{\&{xscaled} primitive@> 17891primitive("yscaled",secondary_binary,y_scaled);@/ 17892@!@:y_scaled_}{\&{yscaled} primitive@> 17893primitive("zscaled",secondary_binary,z_scaled);@/ 17894@!@:z_scaled_}{\&{zscaled} primitive@> 17895primitive("intersectiontimes",tertiary_binary,intersect);@/ 17896@!@:intersection_times_}{\&{intersectiontimes} primitive@> 17897 17898@ @<Cases of |print_cmd...@>= 17899nullary,unary,primary_binary,secondary_binary,tertiary_binary, 17900 expression_binary,cycle,plus_or_minus,slash,ampersand,equals,and_command: 17901 print_op(m); 17902 17903@ OK, let's look at the simplest \\{do} procedure first. 17904 17905@p procedure do_nullary(@!c:quarterword); 17906var @!k:integer; {all-purpose loop index} 17907begin check_arith; 17908if internal[tracing_commands]>two then 17909 show_cmd_mod(nullary,c); 17910case c of 17911true_code,false_code:begin cur_type:=boolean_type; cur_exp:=c; 17912 end; 17913null_picture_code:begin cur_type:=picture_type; 17914 cur_exp:=get_node(edge_header_size); init_edges(cur_exp); 17915 end; 17916null_pen_code:begin cur_type:=pen_type; cur_exp:=null_pen; 17917 end; 17918normal_deviate:begin cur_type:=known; cur_exp:=norm_rand; 17919 end; 17920pen_circle:@<Make a special knot node for \&{pencircle}@>; 17921job_name_op: begin if job_name=0 then open_log_file; 17922 cur_type:=string_type; cur_exp:=job_name; 17923 end; 17924read_string_op:@<Read a string from the terminal@>; 17925end; {there are no other cases} 17926check_arith; 17927end; 17928 17929@ @<Make a special knot node for \&{pencircle}@>= 17930begin cur_type:=future_pen; cur_exp:=get_node(knot_node_size); 17931left_type(cur_exp):=open; right_type(cur_exp):=open; 17932link(cur_exp):=cur_exp;@/ 17933x_coord(cur_exp):=0; y_coord(cur_exp):=0;@/ 17934left_x(cur_exp):=unity; left_y(cur_exp):=0;@/ 17935right_x(cur_exp):=0; right_y(cur_exp):=unity;@/ 17936end 17937 17938@ @<Read a string...@>= 17939begin if interaction<=nonstop_mode then 17940 fatal_error("*** (cannot readstring in nonstop modes)"); 17941begin_file_reading; name:=1; prompt_input(""); 17942str_room(last-start); 17943for k:=start to last-1 do append_char(buffer[k]); 17944end_file_reading; cur_type:=string_type; cur_exp:=make_string; 17945end 17946 17947@ Things get a bit more interesting when there's an operand. The 17948operand to |do_unary| appears in |cur_type| and |cur_exp|. 17949 17950@p @t\4@>@<Declare unary action procedures@>@; 17951procedure do_unary(@!c:quarterword); 17952var @!p,@!q:pointer; {for list manipulation} 17953@!x:integer; {a temporary register} 17954begin check_arith; 17955if internal[tracing_commands]>two then 17956 @<Trace the current unary operation@>; 17957case c of 17958plus:if cur_type<pair_type then 17959 if cur_type<>picture_type then bad_unary(plus); 17960minus:@<Negate the current expression@>; 17961@t\4@>@<Additional cases of unary operators@>@; 17962end; {there are no other cases} 17963check_arith; 17964end; 17965 17966@ The |nice_pair| function returns |true| if both components of a pair 17967are known. 17968 17969@<Declare unary action procedures@>= 17970function nice_pair(@!p:integer;@!t:quarterword):boolean; 17971label exit; 17972begin if t=pair_type then 17973 begin p:=value(p); 17974 if type(x_part_loc(p))=known then 17975 if type(y_part_loc(p))=known then 17976 begin nice_pair:=true; return; 17977 end; 17978 end; 17979nice_pair:=false; 17980exit:end; 17981 17982@ @<Declare unary action...@>= 17983procedure print_known_or_unknown_type(@!t:small_number;@!v:integer); 17984begin print_char("("); 17985if t<dependent then 17986 if t<>pair_type then print_type(t) 17987 else if nice_pair(v,pair_type) then print("pair") 17988 else print("unknown pair") 17989else print("unknown numeric"); 17990print_char(")"); 17991end; 17992 17993@ @<Declare unary action...@>= 17994procedure bad_unary(@!c:quarterword); 17995begin exp_err("Not implemented: "); print_op(c); 17996@.Not implemented...@> 17997print_known_or_unknown_type(cur_type,cur_exp); 17998help3("I'm afraid I don't know how to apply that operation to that")@/ 17999 ("particular type. Continue, and I'll simply return the")@/ 18000 ("argument (shown above) as the result of the operation."); 18001put_get_error; 18002end; 18003 18004@ @<Trace the current unary operation@>= 18005begin begin_diagnostic; print_nl("{"); print_op(c); print_char("(");@/ 18006print_exp(null,0); {show the operand, but not verbosely} 18007print(")}"); end_diagnostic(false); 18008end 18009 18010@ Negation is easy except when the current expression 18011is of type |independent|, or when it is a pair with one or more 18012|independent| components. 18013 18014It is tempting to argue that the negative of an independent variable 18015is an independent variable, hence we don't have to do anything when 18016negating it. The fallacy is that other dependent variables pointing 18017to the current expression must change the sign of their 18018coefficients if we make no change to the current expression. 18019 18020Instead, we work around the problem by copying the current expression 18021and recycling it afterwards (cf.~the |stash_in| routine). 18022 18023@<Negate the current expression@>= 18024case cur_type of 18025pair_type,independent: begin q:=cur_exp; make_exp_copy(q); 18026 if cur_type=dependent then negate_dep_list(dep_list(cur_exp)) 18027 else if cur_type=pair_type then 18028 begin p:=value(cur_exp); 18029 if type(x_part_loc(p))=known then negate(value(x_part_loc(p))) 18030 else negate_dep_list(dep_list(x_part_loc(p))); 18031 if type(y_part_loc(p))=known then negate(value(y_part_loc(p))) 18032 else negate_dep_list(dep_list(y_part_loc(p))); 18033 end; {if |cur_type=known| then |cur_exp=0|} 18034 recycle_value(q); free_node(q,value_node_size); 18035 end; 18036dependent,proto_dependent:negate_dep_list(dep_list(cur_exp)); 18037known:negate(cur_exp); 18038picture_type:negate_edges(cur_exp); 18039othercases bad_unary(minus) 18040endcases 18041 18042@ @<Declare unary action...@>= 18043procedure negate_dep_list(@!p:pointer); 18044label exit; 18045begin loop@+begin negate(value(p)); 18046 if info(p)=null then return; 18047 p:=link(p); 18048 end; 18049exit:end; 18050 18051@ @<Additional cases of unary operators@>= 18052not_op: if cur_type<>boolean_type then bad_unary(not_op) 18053 else cur_exp:=true_code+false_code-cur_exp; 18054 18055@ @d three_sixty_units==23592960 {that's |360*unity|} 18056@d boolean_reset(#)==if # then cur_exp:=true_code@+else cur_exp:=false_code 18057 18058@<Additional cases of unary operators@>= 18059sqrt_op,m_exp_op,m_log_op,sin_d_op,cos_d_op,floor_op, 18060 uniform_deviate,odd_op,char_exists_op:@t@>@;@/ 18061 if cur_type<>known then bad_unary(c) 18062 else case c of 18063 sqrt_op:cur_exp:=square_rt(cur_exp); 18064 m_exp_op:cur_exp:=m_exp(cur_exp); 18065 m_log_op:cur_exp:=m_log(cur_exp); 18066 sin_d_op,cos_d_op:begin n_sin_cos((cur_exp mod three_sixty_units)*16); 18067 if c=sin_d_op then cur_exp:=round_fraction(n_sin) 18068 else cur_exp:=round_fraction(n_cos); 18069 end; 18070 floor_op:cur_exp:=floor_scaled(cur_exp); 18071 uniform_deviate:cur_exp:=unif_rand(cur_exp); 18072 odd_op: begin boolean_reset(odd(round_unscaled(cur_exp))); 18073 cur_type:=boolean_type; 18074 end; 18075 char_exists_op:@<Determine if a character has been shipped out@>; 18076 end; {there are no other cases} 18077 18078@ @<Additional cases of unary operators@>= 18079angle_op:if nice_pair(cur_exp,cur_type) then 18080 begin p:=value(cur_exp); 18081 x:=n_arg(value(x_part_loc(p)),value(y_part_loc(p))); 18082 if x>=0 then flush_cur_exp((x+8)div 16) 18083 else flush_cur_exp(-((-x+8)div 16)); 18084 end 18085 else bad_unary(angle_op); 18086 18087@ If the current expression is a pair, but the context wants it to 18088be a path, we call |pair_to_path|. 18089 18090@<Declare unary action...@>= 18091procedure pair_to_path; 18092begin cur_exp:=new_knot; cur_type:=path_type; 18093end; 18094 18095@ @<Additional cases of unary operators@>= 18096x_part,y_part:if (cur_type<=pair_type)and(cur_type>=transform_type) then 18097 take_part(c) 18098 else bad_unary(c); 18099xx_part,xy_part,yx_part,yy_part: if cur_type=transform_type then take_part(c) 18100 else bad_unary(c); 18101 18102@ In the following procedure, |cur_exp| points to a capsule, which points to 18103a big node. We want to delete all but one part of the big node. 18104 18105@<Declare unary action...@>= 18106procedure take_part(@!c:quarterword); 18107var @!p:pointer; {the big node} 18108begin p:=value(cur_exp); value(temp_val):=p; type(temp_val):=cur_type; 18109link(p):=temp_val; free_node(cur_exp,value_node_size); 18110make_exp_copy(p+2*(c-x_part)); 18111recycle_value(temp_val); 18112end; 18113 18114@ @<Initialize table entries...@>= 18115name_type(temp_val):=capsule; 18116 18117@ @<Additional cases of unary...@>= 18118char_op: if cur_type<>known then bad_unary(char_op) 18119 else begin cur_exp:=round_unscaled(cur_exp) mod 256; cur_type:=string_type; 18120 if cur_exp<0 then cur_exp:=cur_exp+256; 18121 if length(cur_exp)<>1 then 18122 begin str_room(1); append_char(cur_exp); cur_exp:=make_string; 18123 end; 18124 end; 18125decimal: if cur_type<>known then bad_unary(decimal) 18126 else begin old_setting:=selector; selector:=new_string; 18127 print_scaled(cur_exp); cur_exp:=make_string; 18128 selector:=old_setting; cur_type:=string_type; 18129 end; 18130oct_op,hex_op,ASCII_op: if cur_type<>string_type then bad_unary(c) 18131 else str_to_num(c); 18132 18133@ @<Declare unary action...@>= 18134procedure str_to_num(@!c:quarterword); {converts a string to a number} 18135var @!n:integer; {accumulator} 18136@!m:ASCII_code; {current character} 18137@!k:pool_pointer; {index into |str_pool|} 18138@!b:8..16; {radix of conversion} 18139@!bad_char:boolean; {did the string contain an invalid digit?} 18140begin if c=ASCII_op then 18141 if length(cur_exp)=0 then n:=-1 18142 else n:=so(str_pool[str_start[cur_exp]]) 18143else begin if c=oct_op then b:=8@+else b:=16; 18144 n:=0; bad_char:=false; 18145 for k:=str_start[cur_exp] to str_start[cur_exp+1]-1 do 18146 begin m:=so(str_pool[k]); 18147 if (m>="0")and(m<="9") then m:=m-"0" 18148 else if (m>="A")and(m<="F") then m:=m-"A"+10 18149 else if (m>="a")and(m<="f") then m:=m-"a"+10 18150 else begin bad_char:=true; m:=0; 18151 end; 18152 if m>=b then 18153 begin bad_char:=true; m:=0; 18154 end; 18155 if n<32768 div b then n:=n*b+m@+else n:=32767; 18156 end; 18157 @<Give error messages if |bad_char| or |n>=4096|@>; 18158 end; 18159flush_cur_exp(n*unity); 18160end; 18161 18162@ @<Give error messages if |bad_char|...@>= 18163if bad_char then 18164 begin exp_err("String contains illegal digits"); 18165@.String contains illegal digits@> 18166 if c=oct_op then 18167 help1("I zeroed out characters that weren't in the range 0..7.") 18168 else help1("I zeroed out characters that weren't hex digits."); 18169 put_get_error; 18170 end; 18171if n>4095 then 18172 begin print_err("Number too large ("); print_int(n); print_char(")"); 18173@.Number too large@> 18174 help1("I have trouble with numbers greater than 4095; watch out."); 18175 put_get_error; 18176 end 18177 18178@ The length operation is somewhat unusual in that it applies to a variety 18179of different types of operands. 18180 18181@<Additional cases of unary...@>= 18182length_op: if cur_type=string_type then flush_cur_exp(length(cur_exp)*unity) 18183 else if cur_type=path_type then flush_cur_exp(path_length) 18184 else if cur_type=known then cur_exp:=abs(cur_exp) 18185 else if nice_pair(cur_exp,cur_type) then 18186 flush_cur_exp(pyth_add(value(x_part_loc(value(cur_exp))),@| 18187 value(y_part_loc(value(cur_exp))))) 18188 else bad_unary(c); 18189 18190@ @<Declare unary action...@>= 18191function path_length:scaled; {computes the length of the current path} 18192var @!n:scaled; {the path length so far} 18193@!p:pointer; {traverser} 18194begin p:=cur_exp; 18195if left_type(p)=endpoint then n:=-unity@+else n:=0; 18196repeat p:=link(p); n:=n+unity; 18197until p=cur_exp; 18198path_length:=n; 18199end; 18200 18201@ The turning number is computed only with respect to null pens. A different 18202pen might affect the turning number, in degenerate cases, because autorounding 18203will produce a slightly different path, or because excessively large coordinates 18204might be truncated. 18205 18206@<Additional cases of unary...@>= 18207turning_op:if cur_type=pair_type then flush_cur_exp(0) 18208 else if cur_type<>path_type then bad_unary(turning_op) 18209 else if left_type(cur_exp)=endpoint then 18210 flush_cur_exp(0) {not a cyclic path} 18211 else begin cur_pen:=null_pen; cur_path_type:=contour_code; 18212 cur_exp:=make_spec(cur_exp, 18213 fraction_one-half_unit-1-el_gordo,0); 18214 flush_cur_exp(turning_number*unity); {convert to |scaled|} 18215 end; 18216 18217@ @d type_test_end== flush_cur_exp(true_code) 18218 else flush_cur_exp(false_code); 18219 cur_type:=boolean_type; 18220 end 18221@d type_range_end(#)==(cur_type<=#) then type_test_end 18222@d type_range(#)==begin if (cur_type>=#) and type_range_end 18223@d type_test(#)==begin if cur_type=# then type_test_end 18224 18225@<Additional cases of unary operators@>= 18226boolean_type: type_range(boolean_type)(unknown_boolean); 18227string_type: type_range(string_type)(unknown_string); 18228pen_type: type_range(pen_type)(future_pen); 18229path_type: type_range(path_type)(unknown_path); 18230picture_type: type_range(picture_type)(unknown_picture); 18231transform_type,pair_type: type_test(c); 18232numeric_type: type_range(known)(independent); 18233known_op,unknown_op: test_known(c); 18234 18235@ @<Declare unary action procedures@>= 18236procedure test_known(@!c:quarterword); 18237label done; 18238var @!b:true_code..false_code; {is the current expression known?} 18239@!p,@!q:pointer; {locations in a big node} 18240begin b:=false_code; 18241case cur_type of 18242vacuous,boolean_type,string_type,pen_type,future_pen,path_type,picture_type, 18243 known: b:=true_code; 18244transform_type,pair_type:begin p:=value(cur_exp); q:=p+big_node_size[cur_type]; 18245 repeat q:=q-2; 18246 if type(q)<>known then goto done; 18247 until q=p; 18248 b:=true_code; 18249done: end; 18250othercases do_nothing 18251endcases; 18252if c=known_op then flush_cur_exp(b) 18253else flush_cur_exp(true_code+false_code-b); 18254cur_type:=boolean_type; 18255end; 18256 18257@ @<Additional cases of unary operators@>= 18258cycle_op: begin if cur_type<>path_type then flush_cur_exp(false_code) 18259 else if left_type(cur_exp)<>endpoint then flush_cur_exp(true_code) 18260 else flush_cur_exp(false_code); 18261 cur_type:=boolean_type; 18262 end; 18263 18264@ @<Additional cases of unary operators@>= 18265make_pen_op: begin if cur_type=pair_type then pair_to_path; 18266 if cur_type=path_type then cur_type:=future_pen 18267 else bad_unary(make_pen_op); 18268 end; 18269make_path_op: begin if cur_type=future_pen then materialize_pen; 18270 if cur_type<>pen_type then bad_unary(make_path_op) 18271 else begin flush_cur_exp(make_path(cur_exp)); cur_type:=path_type; 18272 end; 18273 end; 18274total_weight_op: if cur_type<>picture_type then bad_unary(total_weight_op) 18275 else flush_cur_exp(total_weight(cur_exp)); 18276reverse: if cur_type=path_type then 18277 begin p:=htap_ypoc(cur_exp); 18278 if right_type(p)=endpoint then p:=link(p); 18279 toss_knot_list(cur_exp); cur_exp:=p; 18280 end 18281 else if cur_type=pair_type then pair_to_path 18282 else bad_unary(reverse); 18283 18284@ Finally, we have the operations that combine a capsule~|p| 18285with the current expression. 18286 18287@p @t\4@>@<Declare binary action procedures@>@; 18288procedure do_binary(@!p:pointer;@!c:quarterword); 18289label done,done1,exit; 18290var @!q,@!r,@!rr:pointer; {for list manipulation} 18291@!old_p,@!old_exp:pointer; {capsules to recycle} 18292@!v:integer; {for numeric manipulation} 18293begin check_arith; 18294if internal[tracing_commands]>two then 18295 @<Trace the current binary operation@>; 18296@<Sidestep |independent| cases in capsule |p|@>; 18297@<Sidestep |independent| cases in the current expression@>; 18298case c of 18299plus,minus:@<Add or subtract the current expression from |p|@>; 18300@t\4@>@<Additional cases of binary operators@>@; 18301end; {there are no other cases} 18302recycle_value(p); free_node(p,value_node_size); {|return| to avoid this} 18303exit:check_arith; @<Recycle any sidestepped |independent| capsules@>; 18304end; 18305 18306@ @<Declare binary action...@>= 18307procedure bad_binary(@!p:pointer;@!c:quarterword); 18308begin disp_err(p,""); 18309exp_err("Not implemented: "); 18310@.Not implemented...@> 18311if c>=min_of then print_op(c); 18312print_known_or_unknown_type(type(p),p); 18313if c>=min_of then print("of")@+else print_op(c); 18314print_known_or_unknown_type(cur_type,cur_exp);@/ 18315help3("I'm afraid I don't know how to apply that operation to that")@/ 18316 ("combination of types. Continue, and I'll return the second")@/ 18317 ("argument (see above) as the result of the operation."); 18318put_get_error; 18319end; 18320 18321@ @<Trace the current binary operation@>= 18322begin begin_diagnostic; print_nl("{("); 18323print_exp(p,0); {show the operand, but not verbosely} 18324print_char(")"); print_op(c); print_char("(");@/ 18325print_exp(null,0); print(")}"); end_diagnostic(false); 18326end 18327 18328@ Several of the binary operations are potentially complicated by the 18329fact that |independent| values can sneak into capsules. For example, 18330we've seen an instance of this difficulty in the unary operation 18331of negation. In order to reduce the number of cases that need to be 18332handled, we first change the two operands (if necessary) 18333to rid them of |independent| components. The original operands are 18334put into capsules called |old_p| and |old_exp|, which will be 18335recycled after the binary operation has been safely carried out. 18336 18337@<Recycle any sidestepped |independent| capsules@>= 18338if old_p<>null then 18339 begin recycle_value(old_p); free_node(old_p,value_node_size); 18340 end; 18341if old_exp<>null then 18342 begin recycle_value(old_exp); free_node(old_exp,value_node_size); 18343 end 18344 18345@ A big node is considered to be ``tarnished'' if it contains at least one 18346independent component. We will define a simple function called `|tarnished|' 18347that returns |null| if and only if its argument is not tarnished. 18348 18349@<Sidestep |independent| cases in capsule |p|@>= 18350case type(p) of 18351transform_type,pair_type: old_p:=tarnished(p); 18352independent: old_p:=void; 18353othercases old_p:=null 18354endcases; 18355if old_p<>null then 18356 begin q:=stash_cur_exp; old_p:=p; make_exp_copy(old_p); 18357 p:=stash_cur_exp; unstash_cur_exp(q); 18358 end; 18359 18360@ @<Sidestep |independent| cases in the current expression@>= 18361case cur_type of 18362transform_type,pair_type:old_exp:=tarnished(cur_exp); 18363independent:old_exp:=void; 18364othercases old_exp:=null 18365endcases; 18366if old_exp<>null then 18367 begin old_exp:=cur_exp; make_exp_copy(old_exp); 18368 end 18369 18370@ @<Declare binary action...@>= 18371function tarnished(@!p:pointer):pointer; 18372label exit; 18373var @!q:pointer; {beginning of the big node} 18374@!r:pointer; {current position in the big node} 18375begin q:=value(p); r:=q+big_node_size[type(p)]; 18376repeat r:=r-2; 18377if type(r)=independent then 18378 begin tarnished:=void; return; 18379 end; 18380until r=q; 18381tarnished:=null; 18382exit:end; 18383 18384@ @<Add or subtract the current expression from |p|@>= 18385if (cur_type<pair_type)or(type(p)<pair_type) then 18386 if (cur_type=picture_type)and(type(p)=picture_type) then 18387 begin if c=minus then negate_edges(cur_exp); 18388 cur_edges:=cur_exp; merge_edges(value(p)); 18389 end 18390 else bad_binary(p,c) 18391else if cur_type=pair_type then 18392 if type(p)<>pair_type then bad_binary(p,c) 18393 else begin q:=value(p); r:=value(cur_exp); 18394 add_or_subtract(x_part_loc(q),x_part_loc(r),c); 18395 add_or_subtract(y_part_loc(q),y_part_loc(r),c); 18396 end 18397 else if type(p)=pair_type then bad_binary(p,c) 18398 else add_or_subtract(p,null,c) 18399 18400@ The first argument to |add_or_subtract| is the location of a value node 18401in a capsule or pair node that will soon be recycled. The second argument 18402is either a location within a pair or transform node of |cur_exp|, 18403or it is null (which means that |cur_exp| itself should be the second 18404argument). The third argument is either |plus| or |minus|. 18405 18406The sum or difference of the numeric quantities will replace the second 18407operand. Arithmetic overflow may go undetected; users aren't supposed to 18408be monkeying around with really big values. 18409@^overflow in arithmetic@> 18410 18411@<Declare binary action...@>= 18412@t\4@>@<Declare the procedure called |dep_finish|@>@; 18413procedure add_or_subtract(@!p,@!q:pointer;@!c:quarterword); 18414label done,exit; 18415var @!s,@!t:small_number; {operand types} 18416@!r:pointer; {list traverser} 18417@!v:integer; {second operand value} 18418begin if q=null then 18419 begin t:=cur_type; 18420 if t<dependent then v:=cur_exp@+else v:=dep_list(cur_exp); 18421 end 18422else begin t:=type(q); 18423 if t<dependent then v:=value(q)@+else v:=dep_list(q); 18424 end; 18425if t=known then 18426 begin if c=minus then negate(v); 18427 if type(p)=known then 18428 begin v:=slow_add(value(p),v); 18429 if q=null then cur_exp:=v@+else value(q):=v; 18430 return; 18431 end; 18432 @<Add a known value to the constant term of |dep_list(p)|@>; 18433 end 18434else begin if c=minus then negate_dep_list(v); 18435 @<Add operand |p| to the dependency list |v|@>; 18436 end; 18437exit:end; 18438 18439@ @<Add a known value to the constant term of |dep_list(p)|@>= 18440r:=dep_list(p); 18441while info(r)<>null do r:=link(r); 18442value(r):=slow_add(value(r),v); 18443if q=null then 18444 begin q:=get_node(value_node_size); cur_exp:=q; cur_type:=type(p); 18445 name_type(q):=capsule; 18446 end; 18447dep_list(q):=dep_list(p); type(q):=type(p); 18448prev_dep(q):=prev_dep(p); link(prev_dep(p)):=q; 18449type(p):=known; {this will keep the recycler from collecting non-garbage} 18450 18451@ We prefer |dependent| lists to |proto_dependent| ones, because it is 18452nice to retain the extra accuracy of |fraction| coefficients. 18453But we have to handle both kinds, and mixtures too. 18454 18455@<Add operand |p| to the dependency list |v|@>= 18456if type(p)=known then 18457 @<Add the known |value(p)| to the constant term of |v|@> 18458else begin s:=type(p); r:=dep_list(p); 18459 if t=dependent then 18460 begin if s=dependent then 18461 if max_coef(r)+max_coef(v)<coef_bound then 18462 begin v:=p_plus_q(v,r,dependent); goto done; 18463 end; {|fix_needed| will necessarily be false} 18464 t:=proto_dependent; v:=p_over_v(v,unity,dependent,proto_dependent); 18465 end; 18466 if s=proto_dependent then v:=p_plus_q(v,r,proto_dependent) 18467 else v:=p_plus_fq(v,unity,r,proto_dependent,dependent); 18468 done: @<Output the answer, |v| (which might have become |known|)@>; 18469 end 18470 18471@ @<Add the known |value(p)| to the constant term of |v|@>= 18472begin while info(v)<>null do v:=link(v); 18473value(v):=slow_add(value(p),value(v)); 18474end 18475 18476@ @<Output the answer, |v| (which might have become |known|)@>= 18477if q<>null then dep_finish(v,q,t) 18478else begin cur_type:=t; dep_finish(v,null,t); 18479 end 18480 18481@ Here's the current situation: The dependency list |v| of type |t| 18482should either be put into the current expression (if |q=null|) or 18483into location |q| within a pair node (otherwise). The destination (|cur_exp| 18484or |q|) formerly held a dependency list with the same 18485final pointer as the list |v|. 18486 18487@<Declare the procedure called |dep_finish|@>= 18488procedure dep_finish(@!v,@!q:pointer;@!t:small_number); 18489var @!p:pointer; {the destination} 18490@!vv:scaled; {the value, if it is |known|} 18491begin if q=null then p:=cur_exp@+else p:=q; 18492dep_list(p):=v; type(p):=t; 18493if info(v)=null then 18494 begin vv:=value(v); 18495 if q=null then flush_cur_exp(vv) 18496 else begin recycle_value(p); type(q):=known; value(q):=vv; 18497 end; 18498 end 18499else if q=null then cur_type:=t; 18500if fix_needed then fix_dependencies; 18501end; 18502 18503@ Let's turn now to the six basic relations of comparison. 18504 18505@<Additional cases of binary operators@>= 18506less_than,less_or_equal,greater_than,greater_or_equal,equal_to,unequal_to: 18507 begin@t@>@; 18508 if (cur_type>pair_type)and(type(p)>pair_type) then 18509 add_or_subtract(p,null,minus) {|cur_exp:=(p)-cur_exp|} 18510 else if cur_type<>type(p) then 18511 begin bad_binary(p,c); goto done; 18512 end 18513 else if cur_type=string_type then 18514 flush_cur_exp(str_vs_str(value(p),cur_exp)) 18515 else if (cur_type=unknown_string)or(cur_type=unknown_boolean) then 18516 @<Check if unknowns have been equated@> 18517 else if (cur_type=pair_type)or(cur_type=transform_type) then 18518 @<Reduce comparison of big nodes to comparison of scalars@> 18519 else if cur_type=boolean_type then flush_cur_exp(cur_exp-value(p)) 18520 else begin bad_binary(p,c); goto done; 18521 end; 18522 @<Compare the current expression with zero@>; 18523done: end; 18524 18525@ @<Compare the current expression with zero@>= 18526if cur_type<>known then 18527 begin if cur_type<known then 18528 begin disp_err(p,""); 18529 help1("The quantities shown above have not been equated.")@/ 18530 end 18531 else help2("Oh dear. I can't decide if the expression above is positive,")@/ 18532 ("negative, or zero. So this comparison test won't be `true'."); 18533 exp_err("Unknown relation will be considered false"); 18534@.Unknown relation...@> 18535 put_get_flush_error(false_code); 18536 end 18537else case c of 18538 less_than: boolean_reset(cur_exp<0); 18539 less_or_equal: boolean_reset(cur_exp<=0); 18540 greater_than: boolean_reset(cur_exp>0); 18541 greater_or_equal: boolean_reset(cur_exp>=0); 18542 equal_to: boolean_reset(cur_exp=0); 18543 unequal_to: boolean_reset(cur_exp<>0); 18544 end; {there are no other cases} 18545 cur_type:=boolean_type 18546 18547@ When two unknown strings are in the same ring, we know that they are 18548equal. Otherwise, we don't know whether they are equal or not, so we 18549make no change. 18550 18551@<Check if unknowns have been equated@>= 18552begin q:=value(cur_exp); 18553while (q<>cur_exp)and(q<>p) do q:=value(q); 18554if q=p then flush_cur_exp(0); 18555end 18556 18557@ @<Reduce comparison of big nodes to comparison of scalars@>= 18558begin q:=value(p); r:=value(cur_exp); 18559rr:=r+big_node_size[cur_type]-2; 18560loop@+ begin add_or_subtract(q,r,minus); 18561 if type(r)<>known then goto done1; 18562 if value(r)<>0 then goto done1; 18563 if r=rr then goto done1; 18564 q:=q+2; r:=r+2; 18565 end; 18566done1:take_part(x_part+half(r-value(cur_exp))); 18567end 18568 18569@ Here we use the sneaky fact that |and_op-false_code=or_op-true_code|. 18570 18571@<Additional cases of binary operators@>= 18572and_op,or_op: if (type(p)<>boolean_type)or(cur_type<>boolean_type) then 18573 bad_binary(p,c) 18574 else if value(p)=c+false_code-and_op then cur_exp:=value(p); 18575 18576@ @<Additional cases of binary operators@>= 18577times: if (cur_type<pair_type)or(type(p)<pair_type) then bad_binary(p,times) 18578 else if (cur_type=known)or(type(p)=known) then 18579 @<Multiply when at least one operand is known@> 18580 else if (nice_pair(p,type(p))and(cur_type>pair_type)) 18581 or(nice_pair(cur_exp,cur_type)and(type(p)>pair_type)) then 18582 begin hard_times(p); return; 18583 end 18584 else bad_binary(p,times); 18585 18586@ @<Multiply when at least one operand is known@>= 18587begin if type(p)=known then 18588 begin v:=value(p); free_node(p,value_node_size); 18589 end 18590else begin v:=cur_exp; unstash_cur_exp(p); 18591 end; 18592if cur_type=known then cur_exp:=take_scaled(cur_exp,v) 18593else if cur_type=pair_type then 18594 begin p:=value(cur_exp); 18595 dep_mult(x_part_loc(p),v,true); 18596 dep_mult(y_part_loc(p),v,true); 18597 end 18598else dep_mult(null,v,true); 18599return; 18600end 18601 18602@ @<Declare binary action...@>= 18603procedure dep_mult(@!p:pointer;@!v:integer;@!v_is_scaled:boolean); 18604label exit; 18605var @!q:pointer; {the dependency list being multiplied by |v|} 18606@!s,@!t:small_number; {its type, before and after} 18607begin if p=null then q:=cur_exp 18608else if type(p)<>known then q:=p 18609else begin if v_is_scaled then value(p):=take_scaled(value(p),v) 18610 else value(p):=take_fraction(value(p),v); 18611 return; 18612 end; 18613t:=type(q); q:=dep_list(q); s:=t; 18614if t=dependent then if v_is_scaled then 18615 if ab_vs_cd(max_coef(q),abs(v),coef_bound-1,unity)>=0 then t:=proto_dependent; 18616q:=p_times_v(q,v,s,t,v_is_scaled); dep_finish(q,p,t); 18617exit:end; 18618 18619@ Here is a routine that is similar to |times|; but it is invoked only 18620internally, when |v| is a |fraction| whose magnitude is at most~1, 18621and when |cur_type>=pair_type|. 18622 18623@p procedure frac_mult(@!n,@!d:scaled); {multiplies |cur_exp| by |n/d|} 18624var @!p:pointer; {a pair node} 18625@!old_exp:pointer; {a capsule to recycle} 18626@!v:fraction; {|n/d|} 18627begin if internal[tracing_commands]>two then 18628 @<Trace the fraction multiplication@>; 18629case cur_type of 18630transform_type,pair_type:old_exp:=tarnished(cur_exp); 18631independent:old_exp:=void; 18632othercases old_exp:=null 18633endcases; 18634if old_exp<>null then 18635 begin old_exp:=cur_exp; make_exp_copy(old_exp); 18636 end; 18637v:=make_fraction(n,d); 18638if cur_type=known then cur_exp:=take_fraction(cur_exp,v) 18639else if cur_type=pair_type then 18640 begin p:=value(cur_exp); 18641 dep_mult(x_part_loc(p),v,false); 18642 dep_mult(y_part_loc(p),v,false); 18643 end 18644else dep_mult(null,v,false); 18645if old_exp<>null then 18646 begin recycle_value(old_exp); free_node(old_exp,value_node_size); 18647 end 18648end; 18649 18650@ @<Trace the fraction multiplication@>= 18651begin begin_diagnostic; print_nl("{("); print_scaled(n); print_char("/"); 18652print_scaled(d); print(")*("); print_exp(null,0); print(")}"); 18653end_diagnostic(false); 18654end 18655 18656@ The |hard_times| routine multiplies a nice pair by a dependency list. 18657 18658@<Declare binary action procedures@>= 18659procedure hard_times(@!p:pointer); 18660var @!q:pointer; {a copy of the dependent variable |p|} 18661@!r:pointer; {the big node for the nice pair} 18662@!u,@!v:scaled; {the known values of the nice pair} 18663begin if type(p)=pair_type then 18664 begin q:=stash_cur_exp; unstash_cur_exp(p); p:=q; 18665 end; {now |cur_type=pair_type|} 18666r:=value(cur_exp); u:=value(x_part_loc(r)); v:=value(y_part_loc(r)); 18667@<Move the dependent variable |p| into both parts of the pair node |r|@>; 18668dep_mult(x_part_loc(r),u,true); dep_mult(y_part_loc(r),v,true); 18669end; 18670 18671@ @<Move the dependent variable |p|...@>= 18672type(y_part_loc(r)):=type(p); 18673new_dep(y_part_loc(r),copy_dep_list(dep_list(p)));@/ 18674type(x_part_loc(r)):=type(p); 18675mem[value_loc(x_part_loc(r))]:=mem[value_loc(p)]; 18676link(prev_dep(p)):=x_part_loc(r); 18677free_node(p,value_node_size) 18678 18679@ @<Additional cases of binary operators@>= 18680over: if (cur_type<>known)or(type(p)<pair_type) then bad_binary(p,over) 18681 else begin v:=cur_exp; unstash_cur_exp(p); 18682 if v=0 then @<Squeal about division by zero@> 18683 else begin if cur_type=known then cur_exp:=make_scaled(cur_exp,v) 18684 else if cur_type=pair_type then 18685 begin p:=value(cur_exp); 18686 dep_div(x_part_loc(p),v); 18687 dep_div(y_part_loc(p),v); 18688 end 18689 else dep_div(null,v); 18690 end; 18691 return; 18692 end; 18693 18694@ @<Declare binary action...@>= 18695procedure dep_div(@!p:pointer;@!v:scaled); 18696label exit; 18697var @!q:pointer; {the dependency list being divided by |v|} 18698@!s,@!t:small_number; {its type, before and after} 18699begin if p=null then q:=cur_exp 18700else if type(p)<>known then q:=p 18701else begin value(p):=make_scaled(value(p),v); return; 18702 end; 18703t:=type(q); q:=dep_list(q); s:=t; 18704if t=dependent then 18705 if ab_vs_cd(max_coef(q),unity,coef_bound-1,abs(v))>=0 then t:=proto_dependent; 18706q:=p_over_v(q,v,s,t); dep_finish(q,p,t); 18707exit:end; 18708 18709@ @<Squeal about division by zero@>= 18710begin exp_err("Division by zero"); 18711@.Division by zero@> 18712help2("You're trying to divide the quantity shown above the error")@/ 18713 ("message by zero. I'm going to divide it by one instead."); 18714put_get_error; 18715end 18716 18717@ @<Additional cases of binary operators@>= 18718pythag_add,pythag_sub: if (cur_type=known)and(type(p)=known) then 18719 if c=pythag_add then cur_exp:=pyth_add(value(p),cur_exp) 18720 else cur_exp:=pyth_sub(value(p),cur_exp) 18721 else bad_binary(p,c); 18722 18723@ The next few sections of the program deal with affine transformations 18724of coordinate data. 18725 18726@<Additional cases of binary operators@>= 18727rotated_by,slanted_by,scaled_by,shifted_by,transformed_by, 18728 x_scaled,y_scaled,z_scaled: @t@>@;@/ 18729 if (type(p)=path_type)or(type(p)=future_pen)or(type(p)=pen_type) then 18730 begin path_trans(p,c); return; 18731 end 18732 else if (type(p)=pair_type)or(type(p)=transform_type) then big_trans(p,c) 18733 else if type(p)=picture_type then 18734 begin edges_trans(p,c); return; 18735 end 18736 else bad_binary(p,c); 18737 18738@ Let |c| be one of the eight transform operators. The procedure call 18739|set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to 18740|c| and the original value of |cur_exp|. (In particular, |cur_exp| doesn't 18741change at all if |c=transformed_by|.) 18742 18743Then, if all components of the resulting transform are |known|, they are 18744moved to the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|; 18745and |cur_exp| is changed to the known value zero. 18746 18747@<Declare binary action...@>= 18748procedure set_up_trans(@!c:quarterword); 18749label done,exit; 18750var @!p,@!q,@!r:pointer; {list manipulation registers} 18751begin if (c<>transformed_by)or(cur_type<>transform_type) then 18752 @<Put the current transform into |cur_exp|@>; 18753@<If the current transform is entirely known, stash it in global variables; 18754 otherwise |return|@>; 18755exit:end; 18756 18757@ @<Glob...@>= 18758@!txx,@!txy,@!tyx,@!tyy,@!tx,@!ty:scaled; {current transform coefficients} 18759 18760@ @<Put the current transform...@>= 18761begin p:=stash_cur_exp; cur_exp:=id_transform; cur_type:=transform_type; 18762q:=value(cur_exp); 18763case c of 18764@<For each of the eight cases, change the relevant fields of |cur_exp| 18765 and |goto done|; 18766 but do nothing if capsule |p| doesn't have the appropriate type@>@; 18767end; {there are no other cases} 18768disp_err(p,"Improper transformation argument"); 18769@.Improper transformation argument@> 18770help3("The expression shown above has the wrong type,")@/ 18771 ("so I can't transform anything using it.")@/ 18772 ("Proceed, and I'll omit the transformation."); 18773put_get_error; 18774done: recycle_value(p); free_node(p,value_node_size); 18775end 18776 18777@ @<If the current transform is entirely known, ...@>= 18778q:=value(cur_exp); r:=q+transform_node_size; 18779repeat r:=r-2; 18780if type(r)<>known then return; 18781until r=q; 18782txx:=value(xx_part_loc(q)); 18783txy:=value(xy_part_loc(q)); 18784tyx:=value(yx_part_loc(q)); 18785tyy:=value(yy_part_loc(q)); 18786tx:=value(x_part_loc(q)); 18787ty:=value(y_part_loc(q)); 18788flush_cur_exp(0) 18789 18790@ @<For each of the eight cases...@>= 18791rotated_by:if type(p)=known then 18792 @<Install sines and cosines, then |goto done|@>; 18793slanted_by:if type(p)>pair_type then 18794 begin install(xy_part_loc(q),p); goto done; 18795 end; 18796scaled_by:if type(p)>pair_type then 18797 begin install(xx_part_loc(q),p); install(yy_part_loc(q),p); goto done; 18798 end; 18799shifted_by:if type(p)=pair_type then 18800 begin r:=value(p); install(x_part_loc(q),x_part_loc(r)); 18801 install(y_part_loc(q),y_part_loc(r)); goto done; 18802 end; 18803x_scaled:if type(p)>pair_type then 18804 begin install(xx_part_loc(q),p); goto done; 18805 end; 18806y_scaled:if type(p)>pair_type then 18807 begin install(yy_part_loc(q),p); goto done; 18808 end; 18809z_scaled:if type(p)=pair_type then 18810 @<Install a complex multiplier, then |goto done|@>; 18811transformed_by:do_nothing; 18812 18813@ @<Install sines and cosines, then |goto done|@>= 18814begin n_sin_cos((value(p) mod three_sixty_units)*16); 18815value(xx_part_loc(q)):=round_fraction(n_cos); 18816value(yx_part_loc(q)):=round_fraction(n_sin); 18817value(xy_part_loc(q)):=-value(yx_part_loc(q)); 18818value(yy_part_loc(q)):=value(xx_part_loc(q)); 18819goto done; 18820end 18821 18822@ @<Install a complex multiplier, then |goto done|@>= 18823begin r:=value(p); 18824install(xx_part_loc(q),x_part_loc(r)); 18825install(yy_part_loc(q),x_part_loc(r)); 18826install(yx_part_loc(q),y_part_loc(r)); 18827if type(y_part_loc(r))=known then negate(value(y_part_loc(r))) 18828else negate_dep_list(dep_list(y_part_loc(r))); 18829install(xy_part_loc(q),y_part_loc(r)); 18830goto done; 18831end 18832 18833@ Procedure |set_up_known_trans| is like |set_up_trans|, but it 18834insists that the transformation be entirely known. 18835 18836@<Declare binary action...@>= 18837procedure set_up_known_trans(@!c:quarterword); 18838begin set_up_trans(c); 18839if cur_type<>known then 18840 begin exp_err("Transform components aren't all known"); 18841@.Transform components...@> 18842 help3("I'm unable to apply a partially specified transformation")@/ 18843 ("except to a fully known pair or transform.")@/ 18844 ("Proceed, and I'll omit the transformation."); 18845 put_get_flush_error(0); 18846 txx:=unity; txy:=0; tyx:=0; tyy:=unity; tx:=0; ty:=0; 18847 end; 18848end; 18849 18850@ Here's a procedure that applies the transform |txx..ty| to a pair of 18851coordinates in locations |p| and~|q|. 18852 18853@<Declare binary action...@>= 18854procedure trans(@!p,@!q:pointer); 18855var @!v:scaled; {the new |x| value} 18856begin v:=take_scaled(mem[p].sc,txx)+take_scaled(mem[q].sc,txy)+tx; 18857mem[q].sc:=take_scaled(mem[p].sc,tyx)+take_scaled(mem[q].sc,tyy)+ty; 18858mem[p].sc:=v; 18859end; 18860 18861@ The simplest transformation procedure applies a transform to all 18862coordinates of a path. The |null_pen| remains unchanged if it isn't 18863being shifted. 18864 18865@<Declare binary action...@>= 18866procedure path_trans(@!p:pointer;@!c:quarterword); 18867label exit; 18868var @!q:pointer; {list traverser} 18869begin set_up_known_trans(c); unstash_cur_exp(p); 18870if cur_type=pen_type then 18871 begin if max_offset(cur_exp)=0 then if tx=0 then if ty=0 then return; 18872 flush_cur_exp(make_path(cur_exp)); cur_type:=future_pen; 18873 end; 18874q:=cur_exp; 18875repeat if left_type(q)<>endpoint then 18876 trans(q+3,q+4); {that's |left_x| and |left_y|} 18877trans(q+1,q+2); {that's |x_coord| and |y_coord|} 18878if right_type(q)<>endpoint then 18879 trans(q+5,q+6); {that's |right_x| and |right_y|} 18880q:=link(q); 18881until q=cur_exp; 18882exit:end; 18883 18884@ The next simplest transformation procedure applies to edges. 18885It is simple primarily because \MF\ doesn't allow very general 18886transformations to be made, and because the tricky subroutines 18887for edge transformation have already been written. 18888 18889@<Declare binary action...@>= 18890procedure edges_trans(@!p:pointer;@!c:quarterword); 18891label exit; 18892begin set_up_known_trans(c); unstash_cur_exp(p); cur_edges:=cur_exp; 18893if empty_edges(cur_edges) then return; {the empty set is easy to transform} 18894if txx=0 then if tyy=0 then 18895 if txy mod unity=0 then if tyx mod unity=0 then 18896 begin xy_swap_edges; txx:=txy; tyy:=tyx; txy:=0; tyx:=0; 18897 if empty_edges(cur_edges) then return; 18898 end; 18899if txy=0 then if tyx=0 then 18900 if txx mod unity=0 then if tyy mod unity=0 then 18901 @<Scale the edges, shift them, and |return|@>; 18902print_err("That transformation is too hard"); 18903@.That transformation...@> 18904help3("I can apply complicated transformations to paths,")@/ 18905 ("but I can only do integer operations on pictures.")@/ 18906 ("Proceed, and I'll omit the transformation."); 18907put_get_error; 18908exit:end; 18909 18910@ @<Scale the edges, shift them, and |return|@>= 18911begin if (txx=0)or(tyy=0) then 18912 begin toss_edges(cur_edges); 18913 cur_exp:=get_node(edge_header_size); init_edges(cur_exp); 18914 end 18915else begin if txx<0 then 18916 begin x_reflect_edges; txx:=-txx; 18917 end; 18918 if tyy<0 then 18919 begin y_reflect_edges; tyy:=-tyy; 18920 end; 18921 if txx<>unity then x_scale_edges(txx div unity); 18922 if tyy<>unity then y_scale_edges(tyy div unity); 18923 @<Shift the edges by |(tx,ty)|, rounded@>; 18924 end; 18925return; 18926end 18927 18928@ @<Shift the edges...@>= 18929tx:=round_unscaled(tx); ty:=round_unscaled(ty); 18930if (m_min(cur_edges)+tx<=0)or(m_max(cur_edges)+tx>=8192)or@| 18931 (n_min(cur_edges)+ty<=0)or(n_max(cur_edges)+ty>=8191)or@| 18932 (abs(tx)>=4096)or(abs(ty)>=4096) then 18933 begin print_err("Too far to shift"); 18934@.Too far to shift@> 18935 help3("I can't shift the picture as requested---it would")@/ 18936 ("make some coordinates too large or too small.")@/ 18937 ("Proceed, and I'll omit the transformation."); 18938 put_get_error; 18939 end 18940else begin if tx<>0 then 18941 begin if not valid_range(m_offset(cur_edges)-tx) then fix_offset; 18942 m_min(cur_edges):=m_min(cur_edges)+tx; 18943 m_max(cur_edges):=m_max(cur_edges)+tx; 18944 m_offset(cur_edges):=m_offset(cur_edges)-tx; 18945 last_window_time(cur_edges):=0; 18946 end; 18947 if ty<>0 then 18948 begin n_min(cur_edges):=n_min(cur_edges)+ty; 18949 n_max(cur_edges):=n_max(cur_edges)+ty; 18950 n_pos(cur_edges):=n_pos(cur_edges)+ty; 18951 last_window_time(cur_edges):=0; 18952 end; 18953 end 18954 18955@ The hard cases of transformation occur when big nodes are involved, 18956and when some of their components are unknown. 18957 18958@<Declare binary action...@>= 18959@t\4@>@<Declare subroutines needed by |big_trans|@>@; 18960procedure big_trans(@!p:pointer;@!c:quarterword); 18961label exit; 18962var @!q,@!r,@!pp,@!qq:pointer; {list manipulation registers} 18963@!s:small_number; {size of a big node} 18964begin s:=big_node_size[type(p)]; q:=value(p); r:=q+s; 18965repeat r:=r-2; 18966if type(r)<>known then @<Transform an unknown big node and |return|@>; 18967until r=q; 18968@<Transform a known big node@>; 18969exit:end; {node |p| will now be recycled by |do_binary|} 18970 18971@ @<Transform an unknown big node and |return|@>= 18972begin set_up_known_trans(c); make_exp_copy(p); r:=value(cur_exp); 18973if cur_type=transform_type then 18974 begin bilin1(yy_part_loc(r),tyy,xy_part_loc(q),tyx,0); 18975 bilin1(yx_part_loc(r),tyy,xx_part_loc(q),tyx,0); 18976 bilin1(xy_part_loc(r),txx,yy_part_loc(q),txy,0); 18977 bilin1(xx_part_loc(r),txx,yx_part_loc(q),txy,0); 18978 end; 18979bilin1(y_part_loc(r),tyy,x_part_loc(q),tyx,ty); 18980bilin1(x_part_loc(r),txx,y_part_loc(q),txy,tx); 18981return; 18982end 18983 18984@ Let |p| point to a two-word value field inside a big node of |cur_exp|, 18985and let |q| point to a another value field. The |bilin1| procedure 18986replaces |p| by $p\cdot t+q\cdot u+\delta$. 18987 18988@<Declare subroutines needed by |big_trans|@>= 18989procedure bilin1(@!p:pointer;@!t:scaled;@!q:pointer;@!u,@!delta:scaled); 18990var @!r:pointer; {list traverser} 18991begin if t<>unity then dep_mult(p,t,true); 18992if u<>0 then 18993 if type(q)=known then delta:=delta+take_scaled(value(q),u) 18994 else begin @<Ensure that |type(p)=proto_dependent|@>; 18995 dep_list(p):=p_plus_fq(dep_list(p),u,dep_list(q),proto_dependent,type(q)); 18996 end; 18997if type(p)=known then value(p):=value(p)+delta 18998else begin r:=dep_list(p); 18999 while info(r)<>null do r:=link(r); 19000 delta:=value(r)+delta; 19001 if r<>dep_list(p) then value(r):=delta 19002 else begin recycle_value(p); type(p):=known; value(p):=delta; 19003 end; 19004 end; 19005if fix_needed then fix_dependencies; 19006end; 19007 19008@ @<Ensure that |type(p)=proto_dependent|@>= 19009if type(p)<>proto_dependent then 19010 begin if type(p)=known then new_dep(p,const_dependency(value(p))) 19011 else dep_list(p):=p_times_v(dep_list(p),unity,dependent,proto_dependent,true); 19012 type(p):=proto_dependent; 19013 end 19014 19015@ @<Transform a known big node@>= 19016set_up_trans(c); 19017if cur_type=known then @<Transform known by known@> 19018else begin pp:=stash_cur_exp; qq:=value(pp); 19019 make_exp_copy(p); r:=value(cur_exp); 19020 if cur_type=transform_type then 19021 begin bilin2(yy_part_loc(r),yy_part_loc(qq), 19022 value(xy_part_loc(q)),yx_part_loc(qq),null); 19023 bilin2(yx_part_loc(r),yy_part_loc(qq), 19024 value(xx_part_loc(q)),yx_part_loc(qq),null); 19025 bilin2(xy_part_loc(r),xx_part_loc(qq), 19026 value(yy_part_loc(q)),xy_part_loc(qq),null); 19027 bilin2(xx_part_loc(r),xx_part_loc(qq), 19028 value(yx_part_loc(q)),xy_part_loc(qq),null); 19029 end; 19030 bilin2(y_part_loc(r),yy_part_loc(qq), 19031 value(x_part_loc(q)),yx_part_loc(qq),y_part_loc(qq)); 19032 bilin2(x_part_loc(r),xx_part_loc(qq), 19033 value(y_part_loc(q)),xy_part_loc(qq),x_part_loc(qq)); 19034 recycle_value(pp); free_node(pp,value_node_size); 19035 end; 19036 19037@ Let |p| be a |proto_dependent| value whose dependency list ends 19038at |dep_final|. The following procedure adds |v| times another 19039numeric quantity to~|p|. 19040 19041@<Declare subroutines needed by |big_trans|@>= 19042procedure add_mult_dep(@!p:pointer;@!v:scaled;@!r:pointer); 19043begin if type(r)=known then 19044 value(dep_final):=value(dep_final)+take_scaled(value(r),v) 19045else begin dep_list(p):= 19046 p_plus_fq(dep_list(p),v,dep_list(r),proto_dependent,type(r)); 19047 if fix_needed then fix_dependencies; 19048 end; 19049end; 19050 19051@ The |bilin2| procedure is something like |bilin1|, but with known 19052and unknown quantities reversed. Parameter |p| points to a value field 19053within the big node for |cur_exp|; and |type(p)=known|. Parameters 19054|t| and~|u| point to value fields elsewhere; so does parameter~|q|, 19055unless it is |null| (which stands for zero). Location~|p| will be 19056replaced by $p\cdot t+v\cdot u+q$. 19057 19058@<Declare subroutines needed by |big_trans|@>= 19059procedure bilin2(@!p,@!t:pointer;@!v:scaled;@!u,@!q:pointer); 19060var @!vv:scaled; {temporary storage for |value(p)|} 19061begin vv:=value(p); type(p):=proto_dependent; 19062new_dep(p,const_dependency(0)); {this sets |dep_final|} 19063if vv<>0 then add_mult_dep(p,vv,t); {|dep_final| doesn't change} 19064if v<>0 then add_mult_dep(p,v,u); 19065if q<>null then add_mult_dep(p,unity,q); 19066if dep_list(p)=dep_final then 19067 begin vv:=value(dep_final); recycle_value(p); 19068 type(p):=known; value(p):=vv; 19069 end; 19070end; 19071 19072@ @<Transform known by known@>= 19073begin make_exp_copy(p); r:=value(cur_exp); 19074if cur_type=transform_type then 19075 begin bilin3(yy_part_loc(r),tyy,value(xy_part_loc(q)),tyx,0); 19076 bilin3(yx_part_loc(r),tyy,value(xx_part_loc(q)),tyx,0); 19077 bilin3(xy_part_loc(r),txx,value(yy_part_loc(q)),txy,0); 19078 bilin3(xx_part_loc(r),txx,value(yx_part_loc(q)),txy,0); 19079 end; 19080bilin3(y_part_loc(r),tyy,value(x_part_loc(q)),tyx,ty); 19081bilin3(x_part_loc(r),txx,value(y_part_loc(q)),txy,tx); 19082end 19083 19084@ Finally, in |bilin3| everything is |known|. 19085 19086@<Declare subroutines needed by |big_trans|@>= 19087procedure bilin3(@!p:pointer;@!t,@!v,@!u,@!delta:scaled); 19088begin if t<>unity then delta:=delta+take_scaled(value(p),t) 19089else delta:=delta+value(p); 19090if u<>0 then value(p):=delta+take_scaled(v,u) 19091else value(p):=delta; 19092end; 19093 19094@ @<Additional cases of binary operators@>= 19095concatenate: if (cur_type=string_type)and(type(p)=string_type) then cat(p) 19096 else bad_binary(p,concatenate); 19097substring_of: if nice_pair(p,type(p))and(cur_type=string_type) then 19098 chop_string(value(p)) 19099 else bad_binary(p,substring_of); 19100subpath_of: begin if cur_type=pair_type then pair_to_path; 19101 if nice_pair(p,type(p))and(cur_type=path_type) then 19102 chop_path(value(p)) 19103 else bad_binary(p,subpath_of); 19104 end; 19105 19106@ @<Declare binary action...@>= 19107procedure cat(@!p:pointer); 19108var @!a,@!b:str_number; {the strings being concatenated} 19109@!k:pool_pointer; {index into |str_pool|} 19110begin a:=value(p); b:=cur_exp; str_room(length(a)+length(b)); 19111for k:=str_start[a] to str_start[a+1]-1 do append_char(so(str_pool[k])); 19112for k:=str_start[b] to str_start[b+1]-1 do append_char(so(str_pool[k])); 19113cur_exp:=make_string; delete_str_ref(b); 19114end; 19115 19116@ @<Declare binary action...@>= 19117procedure chop_string(@!p:pointer); 19118var @!a,@!b:integer; {start and stop points} 19119@!l:integer; {length of the original string} 19120@!k:integer; {runs from |a| to |b|} 19121@!s:str_number; {the original string} 19122@!reversed:boolean; {was |a>b|?} 19123begin a:=round_unscaled(value(x_part_loc(p))); 19124b:=round_unscaled(value(y_part_loc(p))); 19125if a<=b then reversed:=false 19126else begin reversed:=true; k:=a; a:=b; b:=k; 19127 end; 19128s:=cur_exp; l:=length(s); 19129if a<0 then 19130 begin a:=0; 19131 if b<0 then b:=0; 19132 end; 19133if b>l then 19134 begin b:=l; 19135 if a>l then a:=l; 19136 end; 19137str_room(b-a); 19138if reversed then 19139 for k:=str_start[s]+b-1 downto str_start[s]+a do append_char(so(str_pool[k])) 19140else for k:=str_start[s]+a to str_start[s]+b-1 do append_char(so(str_pool[k])); 19141cur_exp:=make_string; delete_str_ref(s); 19142end; 19143 19144@ @<Declare binary action...@>= 19145procedure chop_path(@!p:pointer); 19146var @!q:pointer; {a knot in the original path} 19147@!pp,@!qq,@!rr,@!ss:pointer; {link variables for copies of path nodes} 19148@!a,@!b,@!k,@!l:scaled; {indices for chopping} 19149@!reversed:boolean; {was |a>b|?} 19150begin l:=path_length; a:=value(x_part_loc(p)); b:=value(y_part_loc(p)); 19151if a<=b then reversed:=false 19152else begin reversed:=true; k:=a; a:=b; b:=k; 19153 end; 19154@<Dispense with the cases |a<0| and/or |b>l|@>; 19155q:=cur_exp; 19156while a>=unity do 19157 begin q:=link(q); a:=a-unity; b:=b-unity; 19158 end; 19159if b=a then @<Construct a path from |pp| to |qq| of length zero@> 19160else @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>; 19161left_type(pp):=endpoint; right_type(qq):=endpoint; link(qq):=pp; 19162toss_knot_list(cur_exp); 19163if reversed then 19164 begin cur_exp:=link(htap_ypoc(pp)); toss_knot_list(pp); 19165 end 19166else cur_exp:=pp; 19167end; 19168 19169@ @<Dispense with the cases |a<0| and/or |b>l|@>= 19170if a<0 then 19171 if left_type(cur_exp)=endpoint then 19172 begin a:=0; if b<0 then b:=0; 19173 end 19174 else repeat a:=a+l; b:=b+l; 19175 until a>=0; {a cycle always has length |l>0|} 19176if b>l then if left_type(cur_exp)=endpoint then 19177 begin b:=l; if a>l then a:=l; 19178 end 19179 else while a>=l do 19180 begin a:=a-l; b:=b-l; 19181 end 19182 19183@ @<Construct a path from |pp| to |qq| of length $\lceil b\rceil$@>= 19184begin pp:=copy_knot(q); qq:=pp; 19185repeat q:=link(q); rr:=qq; qq:=copy_knot(q); link(rr):=qq; b:=b-unity; 19186until b<=0; 19187if a>0 then 19188 begin ss:=pp; pp:=link(pp); 19189 split_cubic(ss,a*@'10000,x_coord(pp),y_coord(pp)); pp:=link(ss); 19190 free_node(ss,knot_node_size); 19191 if rr=ss then 19192 begin b:=make_scaled(b,unity-a); rr:=pp; 19193 end; 19194 end; 19195if b<0 then 19196 begin split_cubic(rr,(b+unity)*@'10000,x_coord(qq),y_coord(qq)); 19197 free_node(qq,knot_node_size); 19198 qq:=link(rr); 19199 end; 19200end 19201 19202@ @<Construct a path from |pp| to |qq| of length zero@>= 19203begin if a>0 then 19204 begin qq:=link(q); 19205 split_cubic(q,a*@'10000,x_coord(qq),y_coord(qq)); q:=link(q); 19206 end; 19207pp:=copy_knot(q); qq:=pp; 19208end 19209 19210@ The |pair_value| routine changes the current expression to a 19211given ordered pair of values. 19212 19213@<Declare binary action...@>= 19214procedure pair_value(@!x,@!y:scaled); 19215var @!p:pointer; {a pair node} 19216begin p:=get_node(value_node_size); flush_cur_exp(p); cur_type:=pair_type; 19217type(p):=pair_type; name_type(p):=capsule; init_big_node(p); 19218p:=value(p);@/ 19219type(x_part_loc(p)):=known; value(x_part_loc(p)):=x;@/ 19220type(y_part_loc(p)):=known; value(y_part_loc(p)):=y;@/ 19221end; 19222 19223@ @<Additional cases of binary operators@>= 19224point_of,precontrol_of,postcontrol_of: begin if cur_type=pair_type then 19225 pair_to_path; 19226 if (cur_type=path_type)and(type(p)=known) then 19227 find_point(value(p),c) 19228 else bad_binary(p,c); 19229 end; 19230pen_offset_of: begin if cur_type=future_pen then materialize_pen; 19231 if (cur_type=pen_type)and nice_pair(p,type(p)) then 19232 set_up_offset(value(p)) 19233 else bad_binary(p,pen_offset_of); 19234 end; 19235direction_time_of: begin if cur_type=pair_type then pair_to_path; 19236 if (cur_type=path_type)and nice_pair(p,type(p)) then 19237 set_up_direction_time(value(p)) 19238 else bad_binary(p,direction_time_of); 19239 end; 19240 19241@ @<Declare binary action...@>= 19242procedure set_up_offset(@!p:pointer); 19243begin find_offset(value(x_part_loc(p)),value(y_part_loc(p)),cur_exp); 19244pair_value(cur_x,cur_y); 19245end; 19246@# 19247procedure set_up_direction_time(@!p:pointer); 19248begin flush_cur_exp(find_direction_time(value(x_part_loc(p)), 19249 value(y_part_loc(p)),cur_exp)); 19250end; 19251 19252@ @<Declare binary action...@>= 19253procedure find_point(@!v:scaled;@!c:quarterword); 19254var @!p:pointer; {the path} 19255@!n:scaled; {its length} 19256@!q:pointer; {successor of |p|} 19257begin p:=cur_exp;@/ 19258if left_type(p)=endpoint then n:=-unity@+else n:=0; 19259repeat p:=link(p); n:=n+unity; 19260until p=cur_exp; 19261if n=0 then v:=0 19262else if v<0 then 19263 if left_type(p)=endpoint then v:=0 19264 else v:=n-1-((-v-1) mod n) 19265else if v>n then 19266 if left_type(p)=endpoint then v:=n 19267 else v:=v mod n; 19268p:=cur_exp; 19269while v>=unity do 19270 begin p:=link(p); v:=v-unity; 19271 end; 19272if v<>0 then @<Insert a fractional node by splitting the cubic@>; 19273@<Set the current expression to the desired path coordinates@>; 19274end; 19275 19276@ @<Insert a fractional node...@>= 19277begin q:=link(p); split_cubic(p,v*@'10000,x_coord(q),y_coord(q)); p:=link(p); 19278end 19279 19280@ @<Set the current expression to the desired path coordinates...@>= 19281case c of 19282point_of: pair_value(x_coord(p),y_coord(p)); 19283precontrol_of: if left_type(p)=endpoint then pair_value(x_coord(p),y_coord(p)) 19284 else pair_value(left_x(p),left_y(p)); 19285postcontrol_of: if right_type(p)=endpoint then pair_value(x_coord(p),y_coord(p)) 19286 else pair_value(right_x(p),right_y(p)); 19287end {there are no other cases} 19288 19289@ @<Additional cases of bin...@>= 19290intersect: begin if type(p)=pair_type then 19291 begin q:=stash_cur_exp; unstash_cur_exp(p); 19292 pair_to_path; p:=stash_cur_exp; unstash_cur_exp(q); 19293 end; 19294 if cur_type=pair_type then pair_to_path; 19295 if (cur_type=path_type)and(type(p)=path_type) then 19296 begin path_intersection(value(p),cur_exp); 19297 pair_value(cur_t,cur_tt); 19298 end 19299 else bad_binary(p,intersect); 19300 end; 19301 19302@* \[43] Statements and commands. 19303The chief executive of \MF\ is the |do_statement| routine, which 19304contains the master switch that causes all the various pieces of \MF\ 19305to do their things, in the right order. 19306 19307In a sense, this is the grand climax of the program: It applies all the 19308tools that we have worked so hard to construct. In another sense, this is 19309the messiest part of the program: It necessarily refers to other pieces 19310of code all over the place, so that a person can't fully understand what is 19311going on without paging back and forth to be reminded of conventions that 19312are defined elsewhere. We are now at the hub of the web. 19313 19314The structure of |do_statement| itself is quite simple. The first token 19315of the statement is fetched using |get_x_next|. If it can be the first 19316token of an expression, we look for an equation, an assignment, or a 19317title. Otherwise we use a \&{case} construction to branch at high speed to 19318the appropriate routine for various and sundry other types of commands, 19319each of which has an ``action procedure'' that does the necessary work. 19320 19321The program uses the fact that 19322$$\hbox{|min_primary_command=max_statement_command=type_name|}$$ 19323to interpret a statement that starts with, e.g., `\&{string}', 19324as a type declaration rather than a boolean expression. 19325 19326@p @t\4@>@<Declare generic font output procedures@>@; 19327@t\4@>@<Declare action procedures for use by |do_statement|@>@; 19328procedure do_statement; {governs \MF's activities} 19329begin cur_type:=vacuous; get_x_next; 19330if cur_cmd>max_primary_command then @<Worry about bad statement@> 19331else if cur_cmd>max_statement_command then 19332 @<Do an equation, assignment, title, or 19333 `$\langle\,$expression$\,\rangle\,$\&{endgroup}'@> 19334else @<Do a statement that doesn't begin with an expression@>; 19335if cur_cmd<semicolon then 19336 @<Flush unparsable junk that was found after the statement@>; 19337error_count:=0; 19338end; 19339 19340@ The only command codes |>max_primary_command| that can be present 19341at the beginning of a statement are |semicolon| and higher; these 19342occur when the statement is null. 19343 19344@<Worry about bad statement@>= 19345begin if cur_cmd<semicolon then 19346 begin print_err("A statement can't begin with `"); 19347@.A statement can't begin with x@> 19348 print_cmd_mod(cur_cmd,cur_mod); print_char("'"); 19349 help5("I was looking for the beginning of a new statement.")@/ 19350 ("If you just proceed without changing anything, I'll ignore")@/ 19351 ("everything up to the next `;'. Please insert a semicolon")@/ 19352 ("now in front of anything that you don't want me to delete.")@/ 19353 ("(See Chapter 27 of The METAFONTbook for an example.)");@/ 19354@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 19355 back_error; get_x_next; 19356 end; 19357end 19358 19359@ The help message printed here says that everything is flushed up to 19360a semicolon, but actually the commands |end_group| and |stop| will 19361also terminate a statement. 19362 19363@<Flush unparsable junk that was found after the statement@>= 19364begin print_err("Extra tokens will be flushed"); 19365@.Extra tokens will be flushed@> 19366help6("I've just read as much of that statement as I could fathom,")@/ 19367("so a semicolon should have been next. It's very puzzling...")@/ 19368("but I'll try to get myself back together, by ignoring")@/ 19369("everything up to the next `;'. Please insert a semicolon")@/ 19370("now in front of anything that you don't want me to delete.")@/ 19371("(See Chapter 27 of The METAFONTbook for an example.)");@/ 19372@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 19373back_error; scanner_status:=flushing; 19374repeat get_next; 19375@<Decrease the string reference count...@>; 19376until end_of_statement; {|cur_cmd=semicolon|, |end_group|, or |stop|} 19377scanner_status:=normal; 19378end 19379 19380@ If |do_statement| ends with |cur_cmd=end_group|, we should have 19381|cur_type=vacuous| unless the statement was simply an expression; 19382in the latter case, |cur_type| and |cur_exp| should represent that 19383expression. 19384 19385@<Do a statement that doesn't...@>= 19386begin if internal[tracing_commands]>0 then show_cur_cmd_mod; 19387case cur_cmd of 19388type_name:do_type_declaration; 19389macro_def:if cur_mod>var_def then make_op_def 19390 else if cur_mod>end_def then scan_def; 19391@t\4@>@<Cases of |do_statement| that invoke particular commands@>@; 19392end; {there are no other cases} 19393cur_type:=vacuous; 19394end 19395 19396@ The most important statements begin with expressions. 19397 19398@<Do an equation, assignment, title, or...@>= 19399begin var_flag:=assignment; scan_expression; 19400if cur_cmd<end_group then 19401 begin if cur_cmd=equals then do_equation 19402 else if cur_cmd=assignment then do_assignment 19403 else if cur_type=string_type then @<Do a title@> 19404 else if cur_type<>vacuous then 19405 begin exp_err("Isolated expression"); 19406@.Isolated expression@> 19407 help3("I couldn't find an `=' or `:=' after the")@/ 19408 ("expression that is shown above this error message,")@/ 19409 ("so I guess I'll just ignore it and carry on."); 19410 put_get_error; 19411 end; 19412 flush_cur_exp(0); cur_type:=vacuous; 19413 end; 19414end 19415 19416@ @<Do a title@>= 19417begin if internal[tracing_titles]>0 then 19418 begin print_nl(""); slow_print(cur_exp); update_terminal; 19419 end; 19420if internal[proofing]>0 then 19421 @<Send the current expression as a title to the output file@>; 19422end 19423 19424@ Equations and assignments are performed by the pair of mutually recursive 19425@^recursion@> 19426routines |do_equation| and |do_assignment|. These routines are called when 19427|cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the left-hand 19428side is in |cur_type| and |cur_exp|, while the right-hand side is yet 19429to be scanned. After the routines are finished, |cur_type| and |cur_exp| 19430will be equal to the right-hand side (which will normally be equal 19431to the left-hand side). 19432 19433@<Declare action procedures for use by |do_statement|@>= 19434@t\4@>@<Declare the procedure called |try_eq|@>@; 19435@t\4@>@<Declare the procedure called |make_eq|@>@; 19436procedure@?do_assignment; forward;@t\2@>@/ 19437procedure do_equation; 19438var @!lhs:pointer; {capsule for the left-hand side} 19439@!p:pointer; {temporary register} 19440begin lhs:=stash_cur_exp; get_x_next; var_flag:=assignment; scan_expression; 19441if cur_cmd=equals then do_equation 19442else if cur_cmd=assignment then do_assignment; 19443if internal[tracing_commands]>two then @<Trace the current equation@>; 19444if cur_type=unknown_path then if type(lhs)=pair_type then 19445 begin p:=stash_cur_exp; unstash_cur_exp(lhs); lhs:=p; 19446 end; {in this case |make_eq| will change the pair to a path} 19447make_eq(lhs); {equate |lhs| to |(cur_type,cur_exp)|} 19448end; 19449 19450@ And |do_assignment| is similar to |do_equation|: 19451 19452@<Declare action procedures for use by |do_statement|@>= 19453procedure do_assignment; 19454var @!lhs:pointer; {token list for the left-hand side} 19455@!p:pointer; {where the left-hand value is stored} 19456@!q:pointer; {temporary capsule for the right-hand value} 19457begin if cur_type<>token_list then 19458 begin exp_err("Improper `:=' will be changed to `='"); 19459@.Improper `:='@> 19460 help2("I didn't find a variable name at the left of the `:=',")@/ 19461 ("so I'm going to pretend that you said `=' instead.");@/ 19462 error; do_equation; 19463 end 19464else begin lhs:=cur_exp; cur_type:=vacuous;@/ 19465 get_x_next; var_flag:=assignment; scan_expression; 19466 if cur_cmd=equals then do_equation 19467 else if cur_cmd=assignment then do_assignment; 19468 if internal[tracing_commands]>two then @<Trace the current assignment@>; 19469 if info(lhs)>hash_end then 19470 @<Assign the current expression to an internal variable@> 19471 else @<Assign the current expression to the variable |lhs|@>; 19472 flush_node_list(lhs); 19473 end; 19474end; 19475 19476@ @<Trace the current equation@>= 19477begin begin_diagnostic; print_nl("{("); print_exp(lhs,0); 19478print(")=("); print_exp(null,0); print(")}"); end_diagnostic(false); 19479end 19480 19481@ @<Trace the current assignment@>= 19482begin begin_diagnostic; print_nl("{"); 19483if info(lhs)>hash_end then slow_print(int_name[info(lhs)-(hash_end)]) 19484else show_token_list(lhs,null,1000,0); 19485print(":="); print_exp(null,0); print_char("}"); end_diagnostic(false); 19486end 19487 19488@ @<Assign the current expression to an internal variable@>= 19489if cur_type=known then internal[info(lhs)-(hash_end)]:=cur_exp 19490else begin exp_err("Internal quantity `"); 19491@.Internal quantity...@> 19492 slow_print(int_name[info(lhs)-(hash_end)]); 19493 print("' must receive a known value"); 19494 help2("I can't set an internal quantity to anything but a known")@/ 19495 ("numeric value, so I'll have to ignore this assignment."); 19496 put_get_error; 19497 end 19498 19499@ @<Assign the current expression to the variable |lhs|@>= 19500begin p:=find_variable(lhs); 19501if p<>null then 19502 begin q:=stash_cur_exp; cur_type:=und_type(p); recycle_value(p); 19503 type(p):=cur_type; value(p):=null; make_exp_copy(p); 19504 p:=stash_cur_exp; unstash_cur_exp(q); make_eq(p); 19505 end 19506else begin obliterated(lhs); put_get_error; 19507 end; 19508end 19509 19510 19511@ And now we get to the nitty-gritty. The |make_eq| procedure is given 19512a pointer to a capsule that is to be equated to the current expression. 19513 19514@<Declare the procedure called |make_eq|@>= 19515procedure make_eq(@!lhs:pointer); 19516label restart,done, not_found; 19517var @!t:small_number; {type of the left-hand side} 19518@!v:integer; {value of the left-hand side} 19519@!p,@!q:pointer; {pointers inside of big nodes} 19520begin restart: t:=type(lhs); 19521if t<=pair_type then v:=value(lhs); 19522case t of 19523@t\4@>@<For each type |t|, make an equation and |goto done| unless |cur_type| 19524 is incompatible with~|t|@>@; 19525end; {all cases have been listed} 19526@<Announce that the equation cannot be performed@>; 19527done:check_arith; recycle_value(lhs); free_node(lhs,value_node_size); 19528end; 19529 19530@ @<Announce that the equation cannot be performed@>= 19531disp_err(lhs,""); exp_err("Equation cannot be performed ("); 19532@.Equation cannot be performed@> 19533if type(lhs)<=pair_type then print_type(type(lhs))@+else print("numeric"); 19534print_char("="); 19535if cur_type<=pair_type then print_type(cur_type)@+else print("numeric"); 19536print_char(")");@/ 19537help2("I'm sorry, but I don't know how to make such things equal.")@/ 19538 ("(See the two expressions just above the error message.)"); 19539put_get_error 19540 19541@ @<For each type |t|, make an equation and |goto done| unless...@>= 19542boolean_type,string_type,pen_type,path_type,picture_type: 19543 if cur_type=t+unknown_tag then 19544 begin nonlinear_eq(v,cur_exp,false); unstash_cur_exp(cur_exp); goto done; 19545 end 19546 else if cur_type=t then 19547 @<Report redundant or inconsistent equation and |goto done|@>; 19548unknown_types:if cur_type=t-unknown_tag then 19549 begin nonlinear_eq(cur_exp,lhs,true); goto done; 19550 end 19551 else if cur_type=t then 19552 begin ring_merge(lhs,cur_exp); goto done; 19553 end 19554 else if cur_type=pair_type then if t=unknown_path then 19555 begin pair_to_path; goto restart; 19556 end; 19557transform_type,pair_type:if cur_type=t then 19558 @<Do multiple equations and |goto done|@>; 19559known,dependent,proto_dependent,independent:if cur_type>=known then 19560 begin try_eq(lhs,null); goto done; 19561 end; 19562vacuous:do_nothing; 19563 19564@ @<Report redundant or inconsistent equation and |goto done|@>= 19565begin if cur_type<=string_type then 19566 begin if cur_type=string_type then 19567 begin if str_vs_str(v,cur_exp)<>0 then goto not_found; 19568 end 19569 else if v<>cur_exp then goto not_found; 19570 @<Exclaim about a redundant equation@>; goto done; 19571 end; 19572print_err("Redundant or inconsistent equation"); 19573@.Redundant or inconsistent equation@> 19574help2("An equation between already-known quantities can't help.")@/ 19575 ("But don't worry; continue and I'll just ignore it."); 19576put_get_error; goto done; 19577not_found: print_err("Inconsistent equation"); 19578@.Inconsistent equation@> 19579help2("The equation I just read contradicts what was said before.")@/ 19580 ("But don't worry; continue and I'll just ignore it."); 19581put_get_error; goto done; 19582end 19583 19584@ @<Do multiple equations and |goto done|@>= 19585begin p:=v+big_node_size[t]; q:=value(cur_exp)+big_node_size[t]; 19586repeat p:=p-2; q:=q-2; try_eq(p,q); 19587until p=v; 19588goto done; 19589end 19590 19591@ The first argument to |try_eq| is the location of a value node 19592in a capsule that will soon be recycled. The second argument is 19593either a location within a pair or transform node pointed to by 19594|cur_exp|, or it is |null| (which means that |cur_exp| itself 19595serves as the second argument). The idea is to leave |cur_exp| unchanged, 19596but to equate the two operands. 19597 19598@<Declare the procedure called |try_eq|@>= 19599procedure try_eq(@!l,@!r:pointer); 19600label done,done1; 19601var @!p:pointer; {dependency list for right operand minus left operand} 19602@!t:known..independent; {the type of list |p|} 19603@!q:pointer; {the constant term of |p| is here} 19604@!pp:pointer; {dependency list for right operand} 19605@!tt:dependent..independent; {the type of list |pp|} 19606@!copied:boolean; {have we copied a list that ought to be recycled?} 19607begin @<Remove the left operand from its container, negate it, and 19608 put it into dependency list~|p| with constant term~|q|@>; 19609@<Add the right operand to list |p|@>; 19610if info(p)=null then @<Deal with redundant or inconsistent equation@> 19611else begin linear_eq(p,t); 19612 if r=null then if cur_type<>known then if type(cur_exp)=known then 19613 begin pp:=cur_exp; cur_exp:=value(cur_exp); cur_type:=known; 19614 free_node(pp,value_node_size); 19615 end; 19616 end; 19617end; 19618 19619@ @<Remove the left operand from its container, negate it, and...@>= 19620t:=type(l); 19621if t=known then 19622 begin t:=dependent; p:=const_dependency(-value(l)); q:=p; 19623 end 19624else if t=independent then 19625 begin t:=dependent; p:=single_dependency(l); negate(value(p)); 19626 q:=dep_final; 19627 end 19628else begin p:=dep_list(l); q:=p; 19629 loop@+ begin negate(value(q)); 19630 if info(q)=null then goto done; 19631 q:=link(q); 19632 end; 19633 done: link(prev_dep(l)):=link(q); prev_dep(link(q)):=prev_dep(l); 19634 type(l):=known; 19635 end 19636 19637@ @<Deal with redundant or inconsistent equation@>= 19638begin if abs(value(p))>64 then {off by .001 or more} 19639 begin print_err("Inconsistent equation");@/ 19640@.Inconsistent equation@> 19641 print(" (off by "); print_scaled(value(p)); print_char(")"); 19642 help2("The equation I just read contradicts what was said before.")@/ 19643 ("But don't worry; continue and I'll just ignore it."); 19644 put_get_error; 19645 end 19646else if r=null then @<Exclaim about a redundant equation@>; 19647free_node(p,dep_node_size); 19648end 19649 19650@ @<Add the right operand to list |p|@>= 19651if r=null then 19652 if cur_type=known then 19653 begin value(q):=value(q)+cur_exp; goto done1; 19654 end 19655 else begin tt:=cur_type; 19656 if tt=independent then pp:=single_dependency(cur_exp) 19657 else pp:=dep_list(cur_exp); 19658 end 19659else if type(r)=known then 19660 begin value(q):=value(q)+value(r); goto done1; 19661 end 19662 else begin tt:=type(r); 19663 if tt=independent then pp:=single_dependency(r) 19664 else pp:=dep_list(r); 19665 end; 19666if tt<>independent then copied:=false 19667else begin copied:=true; tt:=dependent; 19668 end; 19669@<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>; 19670if copied then flush_node_list(pp); 19671done1: 19672 19673@ @<Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t|@>= 19674watch_coefs:=false; 19675if t=tt then p:=p_plus_q(p,pp,t) 19676else if t=proto_dependent then 19677 p:=p_plus_fq(p,unity,pp,proto_dependent,dependent) 19678else begin q:=p; 19679 while info(q)<>null do 19680 begin value(q):=round_fraction(value(q)); q:=link(q); 19681 end; 19682 t:=proto_dependent; p:=p_plus_q(p,pp,t); 19683 end; 19684watch_coefs:=true; 19685 19686@ Our next goal is to process type declarations. For this purpose it's 19687convenient to have a procedure that scans a $\langle\,$declared 19688variable$\,\rangle$ and returns the corresponding token list. After the 19689following procedure has acted, the token after the declared variable 19690will have been scanned, so it will appear in |cur_cmd|, |cur_mod|, 19691and~|cur_sym|. 19692 19693@<Declare the function called |scan_declared_variable|@>= 19694function scan_declared_variable:pointer; 19695label done; 19696var @!x:pointer; {hash address of the variable's root} 19697@!h,@!t:pointer; {head and tail of the token list to be returned} 19698@!l:pointer; {hash address of left bracket} 19699begin get_symbol; x:=cur_sym; 19700if cur_cmd<>tag_token then clear_symbol(x,false); 19701h:=get_avail; info(h):=x; t:=h;@/ 19702loop@+ begin get_x_next; 19703 if cur_sym=0 then goto done; 19704 if cur_cmd<>tag_token then if cur_cmd<>internal_quantity then 19705 if cur_cmd=left_bracket then @<Descend past a collective subscript@> 19706 else goto done; 19707 link(t):=get_avail; t:=link(t); info(t):=cur_sym; 19708 end; 19709done: if eq_type(x) mod outer_tag<>tag_token then clear_symbol(x,false); 19710if equiv(x)=null then new_root(x); 19711scan_declared_variable:=h; 19712end; 19713 19714@ If the subscript isn't collective, we don't accept it as part of the 19715declared variable. 19716 19717@<Descend past a collective subscript@>= 19718begin l:=cur_sym; get_x_next; 19719if cur_cmd<>right_bracket then 19720 begin back_input; cur_sym:=l; cur_cmd:=left_bracket; goto done; 19721 end 19722else cur_sym:=collective_subscript; 19723end 19724 19725@ Type declarations are introduced by the following primitive operations. 19726 19727@<Put each...@>= 19728primitive("numeric",type_name,numeric_type);@/ 19729@!@:numeric_}{\&{numeric} primitive@> 19730primitive("string",type_name,string_type);@/ 19731@!@:string_}{\&{string} primitive@> 19732primitive("boolean",type_name,boolean_type);@/ 19733@!@:boolean_}{\&{boolean} primitive@> 19734primitive("path",type_name,path_type);@/ 19735@!@:path_}{\&{path} primitive@> 19736primitive("pen",type_name,pen_type);@/ 19737@!@:pen_}{\&{pen} primitive@> 19738primitive("picture",type_name,picture_type);@/ 19739@!@:picture_}{\&{picture} primitive@> 19740primitive("transform",type_name,transform_type);@/ 19741@!@:transform_}{\&{transform} primitive@> 19742primitive("pair",type_name,pair_type);@/ 19743@!@:pair_}{\&{pair} primitive@> 19744 19745@ @<Cases of |print_cmd...@>= 19746type_name: print_type(m); 19747 19748@ Now we are ready to handle type declarations, assuming that a 19749|type_name| has just been scanned. 19750 19751@<Declare action procedures for use by |do_statement|@>= 19752procedure do_type_declaration; 19753var @!t:small_number; {the type being declared} 19754@!p:pointer; {token list for a declared variable} 19755@!q:pointer; {value node for the variable} 19756begin if cur_mod>=transform_type then t:=cur_mod@+else t:=cur_mod+unknown_tag; 19757repeat p:=scan_declared_variable; 19758flush_variable(equiv(info(p)),link(p),false);@/ 19759q:=find_variable(p); 19760if q<>null then 19761 begin type(q):=t; value(q):=null; 19762 end 19763else begin print_err("Declared variable conflicts with previous vardef"); 19764@.Declared variable conflicts...@> 19765 help2("You can't use, e.g., `numeric foo[]' after `vardef foo'.")@/ 19766 ("Proceed, and I'll ignore the illegal redeclaration."); 19767 put_get_error; 19768 end; 19769flush_list(p); 19770if cur_cmd<comma then @<Flush spurious symbols after the declared variable@>; 19771until end_of_statement; 19772end; 19773 19774@ @<Flush spurious symbols after the declared variable@>= 19775begin print_err("Illegal suffix of declared variable will be flushed"); 19776@.Illegal suffix...flushed@> 19777help5("Variables in declarations must consist entirely of")@/ 19778 ("names and collective subscripts, e.g., `x[]a'.")@/ 19779 ("Are you trying to use a reserved word in a variable name?")@/ 19780 ("I'm going to discard the junk I found here,")@/ 19781 ("up to the next comma or the end of the declaration."); 19782if cur_cmd=numeric_token then 19783 help_line[2]:="Explicit subscripts like `x15a' aren't permitted."; 19784put_get_error; scanner_status:=flushing; 19785repeat get_next; 19786@<Decrease the string reference count...@>; 19787until cur_cmd>=comma; {either |end_of_statement| or |cur_cmd=comma|} 19788scanner_status:=normal; 19789end 19790 19791@ \MF's |main_control| procedure just calls |do_statement| repeatedly 19792until coming to the end of the user's program. 19793Each execution of |do_statement| concludes with 19794|cur_cmd=semicolon|, |end_group|, or |stop|. 19795 19796@p procedure main_control; 19797begin repeat do_statement; 19798if cur_cmd=end_group then 19799 begin print_err("Extra `endgroup'"); 19800@.Extra `endgroup'@> 19801 help2("I'm not currently working on a `begingroup',")@/ 19802 ("so I had better not try to end anything."); 19803 flush_error(0); 19804 end; 19805until cur_cmd=stop; 19806end; 19807 19808@ @<Put each...@>= 19809primitive("end",stop,0);@/ 19810@!@:end_}{\&{end} primitive@> 19811primitive("dump",stop,1);@/ 19812@!@:dump_}{\&{dump} primitive@> 19813 19814@ @<Cases of |print_cmd...@>= 19815stop:if m=0 then print("end")@+else print("dump"); 19816 19817@* \[44] Commands. 19818Let's turn now to statements that are classified as ``commands'' because 19819of their imperative nature. We'll begin with simple ones, so that it 19820will be clear how to hook command processing into the |do_statement| routine; 19821then we'll tackle the tougher commands. 19822 19823Here's one of the simplest: 19824 19825@<Cases of |do_statement|...@>= 19826random_seed: do_random_seed; 19827 19828@ @<Declare action procedures for use by |do_statement|@>= 19829procedure do_random_seed; 19830begin get_x_next; 19831if cur_cmd<>assignment then 19832 begin missing_err(":="); 19833@.Missing `:='@> 19834 help1("Always say `randomseed:=<numeric expression>'."); 19835 back_error; 19836 end; 19837get_x_next; scan_expression; 19838if cur_type<>known then 19839 begin exp_err("Unknown value will be ignored"); 19840@.Unknown value...ignored@> 19841 help2("Your expression was too random for me to handle,")@/ 19842 ("so I won't change the random seed just now.");@/ 19843 put_get_flush_error(0); 19844 end 19845else @<Initialize the random seed to |cur_exp|@>; 19846end; 19847 19848@ @<Initialize the random seed to |cur_exp|@>= 19849begin init_randoms(cur_exp); 19850if selector>=log_only then 19851 begin old_setting:=selector; selector:=log_only; 19852 print_nl("{randomseed:="); print_scaled(cur_exp); print_char("}"); 19853 print_nl(""); selector:=old_setting; 19854 end; 19855end 19856 19857@ And here's another simple one (somewhat different in flavor): 19858 19859@<Cases of |do_statement|...@>= 19860mode_command: begin print_ln; interaction:=cur_mod; 19861 @<Initialize the print |selector| based on |interaction|@>; 19862 if log_opened then selector:=selector+2; 19863 get_x_next; 19864 end; 19865 19866@ @<Put each...@>= 19867primitive("batchmode",mode_command,batch_mode); 19868@!@:batch_mode_}{\&{batchmode} primitive@> 19869primitive("nonstopmode",mode_command,nonstop_mode); 19870@!@:nonstop_mode_}{\&{nonstopmode} primitive@> 19871primitive("scrollmode",mode_command,scroll_mode); 19872@!@:scroll_mode_}{\&{scrollmode} primitive@> 19873primitive("errorstopmode",mode_command,error_stop_mode); 19874@!@:error_stop_mode_}{\&{errorstopmode} primitive@> 19875 19876@ @<Cases of |print_cmd_mod|...@>= 19877mode_command: case m of 19878 batch_mode: print("batchmode"); 19879 nonstop_mode: print("nonstopmode"); 19880 scroll_mode: print("scrollmode"); 19881 othercases print("errorstopmode") 19882 endcases; 19883 19884@ The `\&{inner}' and `\&{outer}' commands are only slightly harder. 19885 19886@<Cases of |do_statement|...@>= 19887protection_command: do_protection; 19888 19889@ @<Put each...@>= 19890primitive("inner",protection_command,0);@/ 19891@!@:inner_}{\&{inner} primitive@> 19892primitive("outer",protection_command,1);@/ 19893@!@:outer_}{\&{outer} primitive@> 19894 19895@ @<Cases of |print_cmd...@>= 19896protection_command: if m=0 then print("inner")@+else print("outer"); 19897 19898@ @<Declare action procedures for use by |do_statement|@>= 19899procedure do_protection; 19900var @!m:0..1; {0 to unprotect, 1 to protect} 19901@!t:halfword; {the |eq_type| before we change it} 19902begin m:=cur_mod; 19903repeat get_symbol; t:=eq_type(cur_sym); 19904 if m=0 then 19905 begin if t>=outer_tag then eq_type(cur_sym):=t-outer_tag; 19906 end 19907 else if t<outer_tag then eq_type(cur_sym):=t+outer_tag; 19908 get_x_next; 19909until cur_cmd<>comma; 19910end; 19911 19912@ \MF\ never defines the tokens `\.(' and `\.)' to be primitives, but 19913plain \MF\ begins with the declaration `\&{delimiters} \.{()}'. Such a 19914declaration assigns the command code |left_delimiter| to `\.{(}' and 19915|right_delimiter| to `\.{)}'; the |equiv| of each delimiter is the 19916hash address of its mate. 19917 19918@<Cases of |do_statement|...@>= 19919delimiters: def_delims; 19920 19921@ @<Declare action procedures for use by |do_statement|@>= 19922procedure def_delims; 19923var l_delim,r_delim:pointer; {the new delimiter pair} 19924begin get_clear_symbol; l_delim:=cur_sym;@/ 19925get_clear_symbol; r_delim:=cur_sym;@/ 19926eq_type(l_delim):=left_delimiter; equiv(l_delim):=r_delim;@/ 19927eq_type(r_delim):=right_delimiter; equiv(r_delim):=l_delim;@/ 19928get_x_next; 19929end; 19930 19931@ Here is a procedure that is called when \MF\ has reached a point 19932where some right delimiter is mandatory. 19933 19934@<Declare the procedure called |check_delimiter|@>= 19935procedure check_delimiter(@!l_delim,@!r_delim:pointer); 19936label exit; 19937begin if cur_cmd=right_delimiter then if cur_mod=l_delim then return; 19938if cur_sym<>r_delim then 19939 begin missing_err(text(r_delim));@/ 19940@.Missing `)'@> 19941 help2("I found no right delimiter to match a left one. So I've")@/ 19942 ("put one in, behind the scenes; this may fix the problem."); 19943 back_error; 19944 end 19945else begin print_err("The token `"); slow_print(text(r_delim)); 19946@.The token...delimiter@> 19947 print("' is no longer a right delimiter"); 19948 help3("Strange: This token has lost its former meaning!")@/ 19949 ("I'll read it as a right delimiter this time;")@/ 19950 ("but watch out, I'll probably miss it later."); 19951 error; 19952 end; 19953exit:end; 19954 19955@ The next four commands save or change the values associated with tokens. 19956 19957@<Cases of |do_statement|...@>= 19958save_command: repeat get_symbol; save_variable(cur_sym); get_x_next; 19959 until cur_cmd<>comma; 19960interim_command: do_interim; 19961let_command: do_let; 19962new_internal: do_new_internal; 19963 19964@ @<Declare action procedures for use by |do_statement|@>= 19965procedure@?do_statement; forward;@t\2@>@/ 19966procedure do_interim; 19967begin get_x_next; 19968if cur_cmd<>internal_quantity then 19969 begin print_err("The token `"); 19970@.The token...quantity@> 19971 if cur_sym=0 then print("(%CAPSULE)") 19972 else slow_print(text(cur_sym)); 19973 print("' isn't an internal quantity"); 19974 help1("Something like `tracingonline' should follow `interim'."); 19975 back_error; 19976 end 19977else begin save_internal(cur_mod); back_input; 19978 end; 19979do_statement; 19980end; 19981 19982@ The following procedure is careful not to undefine the left-hand symbol 19983too soon, lest commands like `{\tt let x=x}' have a surprising effect. 19984 19985@<Declare action procedures for use by |do_statement|@>= 19986procedure do_let; 19987var @!l:pointer; {hash location of the left-hand symbol} 19988begin get_symbol; l:=cur_sym; get_x_next; 19989if cur_cmd<>equals then if cur_cmd<>assignment then 19990 begin missing_err("="); 19991@.Missing `='@> 19992 help3("You should have said `let symbol = something'.")@/ 19993 ("But don't worry; I'll pretend that an equals sign")@/ 19994 ("was present. The next token I read will be `something'."); 19995 back_error; 19996 end; 19997get_symbol; 19998case cur_cmd of 19999defined_macro,secondary_primary_macro,tertiary_secondary_macro, 20000 expression_tertiary_macro: add_mac_ref(cur_mod); 20001othercases do_nothing 20002endcases;@/ 20003clear_symbol(l,false); eq_type(l):=cur_cmd; 20004if cur_cmd=tag_token then equiv(l):=null 20005else equiv(l):=cur_mod; 20006get_x_next; 20007end; 20008 20009@ @<Declare action procedures for use by |do_statement|@>= 20010procedure do_new_internal; 20011begin repeat if int_ptr=max_internal then 20012 overflow("number of internals",max_internal); 20013@:METAFONT capacity exceeded number of int}{\quad number of internals@> 20014get_clear_symbol; incr(int_ptr); 20015eq_type(cur_sym):=internal_quantity; equiv(cur_sym):=int_ptr; 20016int_name[int_ptr]:=text(cur_sym); internal[int_ptr]:=0; 20017get_x_next; 20018until cur_cmd<>comma; 20019end; 20020 20021@ The various `\&{show}' commands are distinguished by modifier fields 20022in the usual way. 20023 20024@d show_token_code=0 {show the meaning of a single token} 20025@d show_stats_code=1 {show current memory and string usage} 20026@d show_code=2 {show a list of expressions} 20027@d show_var_code=3 {show a variable and its descendents} 20028@d show_dependencies_code=4 {show dependent variables in terms of independents} 20029 20030@<Put each...@>= 20031primitive("showtoken",show_command,show_token_code);@/ 20032@!@:show_token_}{\&{showtoken} primitive@> 20033primitive("showstats",show_command,show_stats_code);@/ 20034@!@:show_stats_}{\&{showstats} primitive@> 20035primitive("show",show_command,show_code);@/ 20036@!@:show_}{\&{show} primitive@> 20037primitive("showvariable",show_command,show_var_code);@/ 20038@!@:show_var_}{\&{showvariable} primitive@> 20039primitive("showdependencies",show_command,show_dependencies_code);@/ 20040@!@:show_dependencies_}{\&{showdependencies} primitive@> 20041 20042@ @<Cases of |print_cmd...@>= 20043show_command: case m of 20044 show_token_code:print("showtoken"); 20045 show_stats_code:print("showstats"); 20046 show_code:print("show"); 20047 show_var_code:print("showvariable"); 20048 othercases print("showdependencies") 20049 endcases; 20050 20051@ @<Cases of |do_statement|...@>= 20052show_command:do_show_whatever; 20053 20054@ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine: 20055If it's |show_code|, complicated structures are abbreviated, otherwise 20056they aren't. 20057 20058@<Declare action procedures for use by |do_statement|@>= 20059procedure do_show; 20060begin repeat get_x_next; scan_expression; 20061print_nl(">> "); 20062@.>>@> 20063print_exp(null,2); flush_cur_exp(0); 20064until cur_cmd<>comma; 20065end; 20066 20067@ @<Declare action procedures for use by |do_statement|@>= 20068procedure disp_token; 20069begin print_nl("> "); 20070@.>\relax@> 20071if cur_sym=0 then @<Show a numeric or string or capsule token@> 20072else begin slow_print(text(cur_sym)); print_char("="); 20073 if eq_type(cur_sym)>=outer_tag then print("(outer) "); 20074 print_cmd_mod(cur_cmd,cur_mod); 20075 if cur_cmd=defined_macro then 20076 begin print_ln; show_macro(cur_mod,null,100000); 20077 end; {this avoids recursion between |show_macro| and |print_cmd_mod|} 20078@^recursion@> 20079 end; 20080end; 20081 20082@ @<Show a numeric or string or capsule token@>= 20083begin if cur_cmd=numeric_token then print_scaled(cur_mod) 20084else if cur_cmd=capsule_token then 20085 begin g_pointer:=cur_mod; print_capsule; 20086 end 20087else begin print_char(""""); slow_print(cur_mod); print_char(""""); 20088 delete_str_ref(cur_mod); 20089 end; 20090end 20091 20092@ The following cases of |print_cmd_mod| might arise in connection 20093with |disp_token|, although they don't necessarily correspond to 20094primitive tokens. 20095 20096@<Cases of |print_cmd_...@>= 20097left_delimiter,right_delimiter: begin if c=left_delimiter then print("lef") 20098 else print("righ"); 20099 print("t delimiter that matches "); slow_print(text(m)); 20100 end; 20101tag_token:if m=null then print("tag")@+else print("variable"); 20102defined_macro: print("macro:"); 20103secondary_primary_macro,tertiary_secondary_macro,expression_tertiary_macro: 20104 begin print_cmd_mod(macro_def,c); print("'d macro:"); 20105 print_ln; show_token_list(link(link(m)),null,1000,0); 20106 end; 20107repeat_loop:print("[repeat the loop]"); 20108internal_quantity:slow_print(int_name[m]); 20109 20110@ @<Declare action procedures for use by |do_statement|@>= 20111procedure do_show_token; 20112begin repeat get_next; disp_token; 20113get_x_next; 20114until cur_cmd<>comma; 20115end; 20116 20117@ @<Declare action procedures for use by |do_statement|@>= 20118procedure do_show_stats; 20119begin print_nl("Memory usage "); 20120@.Memory usage...@> 20121@!stat print_int(var_used); print_char("&"); print_int(dyn_used); 20122if false then@+tats@t@>@;@/ 20123print("unknown"); 20124print(" ("); print_int(hi_mem_min-lo_mem_max-1); 20125print(" still untouched)"); print_ln; 20126print_nl("String usage "); 20127print_int(str_ptr-init_str_ptr); print_char("&"); 20128print_int(pool_ptr-init_pool_ptr); 20129print(" ("); 20130print_int(max_strings-max_str_ptr); print_char("&"); 20131print_int(pool_size-max_pool_ptr); print(" still untouched)"); print_ln; 20132get_x_next; 20133end; 20134 20135@ Here's a recursive procedure that gives an abbreviated account 20136of a variable, for use by |do_show_var|. 20137 20138@<Declare action procedures for use by |do_statement|@>= 20139procedure disp_var(@!p:pointer); 20140var @!q:pointer; {traverses attributes and subscripts} 20141@!n:0..max_print_line; {amount of macro text to show} 20142begin if type(p)=structured then @<Descend the structure@> 20143else if type(p)>=unsuffixed_macro then @<Display a variable macro@> 20144else if type(p)<>undefined then 20145 begin print_nl(""); print_variable_name(p); print_char("="); 20146 print_exp(p,0); 20147 end; 20148end; 20149 20150@ @<Descend the structure@>= 20151begin q:=attr_head(p); 20152repeat disp_var(q); q:=link(q); 20153until q=end_attr; 20154q:=subscr_head(p); 20155while name_type(q)=subscr do 20156 begin disp_var(q); q:=link(q); 20157 end; 20158end 20159 20160@ @<Display a variable macro@>= 20161begin print_nl(""); print_variable_name(p); 20162if type(p)>unsuffixed_macro then print("@@#"); {|suffixed_macro|} 20163print("=macro:"); 20164if file_offset>=max_print_line-20 then n:=5 20165else n:=max_print_line-file_offset-15; 20166show_macro(value(p),null,n); 20167end 20168 20169@ @<Declare action procedures for use by |do_statement|@>= 20170procedure do_show_var; 20171label done; 20172begin repeat get_next; 20173if cur_sym>0 then if cur_sym<=hash_end then 20174 if cur_cmd=tag_token then if cur_mod<>null then 20175 begin disp_var(cur_mod); goto done; 20176 end; 20177disp_token; 20178done:get_x_next; 20179until cur_cmd<>comma; 20180end; 20181 20182@ @<Declare action procedures for use by |do_statement|@>= 20183procedure do_show_dependencies; 20184var @!p:pointer; {link that runs through all dependencies} 20185begin p:=link(dep_head); 20186while p<>dep_head do 20187 begin if interesting(p) then 20188 begin print_nl(""); print_variable_name(p); 20189 if type(p)=dependent then print_char("=") 20190 else print(" = "); {extra spaces imply proto-dependency} 20191 print_dependency(dep_list(p),type(p)); 20192 end; 20193 p:=dep_list(p); 20194 while info(p)<>null do p:=link(p); 20195 p:=link(p); 20196 end; 20197get_x_next; 20198end; 20199 20200@ Finally we are ready for the procedure that governs all of the 20201show commands. 20202 20203@<Declare action procedures for use by |do_statement|@>= 20204procedure do_show_whatever; 20205begin if interaction=error_stop_mode then wake_up_terminal; 20206case cur_mod of 20207show_token_code:do_show_token; 20208show_stats_code:do_show_stats; 20209show_code:do_show; 20210show_var_code:do_show_var; 20211show_dependencies_code:do_show_dependencies; 20212end; {there are no other cases} 20213if internal[showstopping]>0 then 20214 begin print_err("OK"); 20215@.OK@> 20216 if interaction<error_stop_mode then 20217 begin help0; decr(error_count); 20218 end 20219 else help1("This isn't an error message; I'm just showing something."); 20220 if cur_cmd=semicolon then error@+else put_get_error; 20221 end; 20222end; 20223 20224@ The `\&{addto}' command needs the following additional primitives: 20225 20226@d drop_code=0 {command modifier for `\&{dropping}'} 20227@d keep_code=1 {command modifier for `\&{keeping}'} 20228 20229@<Put each...@>= 20230primitive("contour",thing_to_add,contour_code);@/ 20231@!@:contour_}{\&{contour} primitive@> 20232primitive("doublepath",thing_to_add,double_path_code);@/ 20233@!@:double_path_}{\&{doublepath} primitive@> 20234primitive("also",thing_to_add,also_code);@/ 20235@!@:also_}{\&{also} primitive@> 20236primitive("withpen",with_option,pen_type);@/ 20237@!@:with_pen_}{\&{withpen} primitive@> 20238primitive("withweight",with_option,known);@/ 20239@!@:with_weight_}{\&{withweight} primitive@> 20240primitive("dropping",cull_op,drop_code);@/ 20241@!@:dropping_}{\&{dropping} primitive@> 20242primitive("keeping",cull_op,keep_code);@/ 20243@!@:keeping_}{\&{keeping} primitive@> 20244 20245@ @<Cases of |print_cmd...@>= 20246thing_to_add:if m=contour_code then print("contour") 20247 else if m=double_path_code then print("doublepath") 20248 else print("also"); 20249with_option:if m=pen_type then print("withpen") 20250 else print("withweight"); 20251cull_op:if m=drop_code then print("dropping") 20252 else print("keeping"); 20253 20254@ @<Declare action procedures for use by |do_statement|@>= 20255function scan_with:boolean; 20256var @!t:small_number; {|known| or |pen_type|} 20257@!result:boolean; {the value to return} 20258begin t:=cur_mod; cur_type:=vacuous; get_x_next; scan_expression; 20259result:=false; 20260if cur_type<>t then @<Complain about improper type@> 20261else if cur_type=pen_type then result:=true 20262else @<Check the tentative weight@>; 20263scan_with:=result; 20264end; 20265 20266@ @<Complain about improper type@>= 20267begin exp_err("Improper type"); 20268@.Improper type@> 20269help2("Next time say `withweight <known numeric expression>';")@/ 20270 ("I'll ignore the bad `with' clause and look for another."); 20271if t=pen_type then 20272 help_line[1]:="Next time say `withpen <known pen expression>';"; 20273put_get_flush_error(0); 20274end 20275 20276@ @<Check the tentative weight@>= 20277begin cur_exp:=round_unscaled(cur_exp); 20278if (abs(cur_exp)<4)and(cur_exp<>0) then result:=true 20279else begin print_err("Weight must be -3, -2, -1, +1, +2, or +3"); 20280@.Weight must be...@> 20281 help1("I'll ignore the bad `with' clause and look for another."); 20282 put_get_flush_error(0); 20283 end; 20284end 20285 20286@ One of the things we need to do when we've parsed an \&{addto} or 20287similar command is set |cur_edges| to the header of a supposed \&{picture} 20288variable, given a token list for that variable. 20289 20290@<Declare action procedures for use by |do_statement|@>= 20291procedure find_edges_var(@!t:pointer); 20292var @!p:pointer; 20293begin p:=find_variable(t); cur_edges:=null; 20294if p=null then 20295 begin obliterated(t); put_get_error; 20296 end 20297else if type(p)<>picture_type then 20298 begin print_err("Variable "); show_token_list(t,null,1000,0); 20299@.Variable x is the wrong type@> 20300 print(" is the wrong type ("); print_type(type(p)); print_char(")"); 20301 help2("I was looking for a ""known"" picture variable.")@/ 20302 ("So I'll not change anything just now."); put_get_error; 20303 end 20304else cur_edges:=value(p); 20305flush_node_list(t); 20306end; 20307 20308@ @<Cases of |do_statement|...@>= 20309add_to_command: do_add_to; 20310 20311@ @<Declare action procedures for use by |do_statement|@>= 20312procedure do_add_to; 20313label done, not_found; 20314var @!lhs,@!rhs:pointer; {variable on left, path on right} 20315@!w:integer; {tentative weight} 20316@!p:pointer; {list manipulation register} 20317@!q:pointer; {beginning of second half of doubled path} 20318@!add_to_type:double_path_code..also_code; {modifier of \&{addto}} 20319begin get_x_next; var_flag:=thing_to_add; scan_primary; 20320if cur_type<>token_list then 20321 @<Abandon edges command because there's no variable@> 20322else begin lhs:=cur_exp; add_to_type:=cur_mod;@/ 20323 cur_type:=vacuous; get_x_next; scan_expression; 20324 if add_to_type=also_code then @<Augment some edges by others@> 20325 else @<Get ready to fill a contour, and fill it@>; 20326 end; 20327end; 20328 20329@ @<Abandon edges command because there's no variable@>= 20330begin exp_err("Not a suitable variable"); 20331@.Not a suitable variable@> 20332help4("At this point I needed to see the name of a picture variable.")@/ 20333 ("(Or perhaps you have indeed presented me with one; I might")@/ 20334 ("have missed it, if it wasn't followed by the proper token.)")@/ 20335 ("So I'll not change anything just now."); 20336put_get_flush_error(0); 20337end 20338 20339@ @<Augment some edges by others@>= 20340begin find_edges_var(lhs); 20341if cur_edges=null then flush_cur_exp(0) 20342else if cur_type<>picture_type then 20343 begin exp_err("Improper `addto'"); 20344@.Improper `addto'@> 20345 help2("This expression should have specified a known picture.")@/ 20346 ("So I'll not change anything just now."); put_get_flush_error(0); 20347 end 20348else begin merge_edges(cur_exp); flush_cur_exp(0); 20349 end; 20350end 20351 20352@ @<Get ready to fill a contour...@>= 20353begin if cur_type=pair_type then pair_to_path; 20354if cur_type<>path_type then 20355 begin exp_err("Improper `addto'"); 20356@.Improper `addto'@> 20357 help2("This expression should have been a known path.")@/ 20358 ("So I'll not change anything just now."); 20359 put_get_flush_error(0); flush_token_list(lhs); 20360 end 20361else begin rhs:=cur_exp; w:=1; cur_pen:=null_pen; 20362 while cur_cmd=with_option do 20363 if scan_with then 20364 if cur_type=known then w:=cur_exp 20365 else @<Change the tentative pen@>; 20366 @<Complete the contour filling operation@>; 20367 delete_pen_ref(cur_pen); 20368 end; 20369end 20370 20371@ We could say `|add_pen_ref(cur_pen)|; |flush_cur_exp(0)|' after changing 20372|cur_pen| here. But that would have no effect, because the current expression 20373will not be flushed. Thus we save a bit of code (at the risk of being too 20374tricky). 20375 20376@<Change the tentative pen@>= 20377begin delete_pen_ref(cur_pen); cur_pen:=cur_exp; 20378end 20379 20380@ @<Complete the contour filling...@>= 20381find_edges_var(lhs); 20382if cur_edges=null then toss_knot_list(rhs) 20383else begin lhs:=null; cur_path_type:=add_to_type; 20384 if left_type(rhs)=endpoint then 20385 if cur_path_type=double_path_code then @<Double the path@> 20386 else @<Complain about non-cycle and |goto not_found|@> 20387 else if cur_path_type=double_path_code then lhs:=htap_ypoc(rhs); 20388 cur_wt:=w; rhs:=make_spec(rhs,max_offset(cur_pen),internal[tracing_specs]); 20389 @<Check the turning number@>; 20390 if max_offset(cur_pen)=0 then fill_spec(rhs) 20391 else fill_envelope(rhs); 20392 if lhs<>null then 20393 begin rev_turns:=true; 20394 lhs:=make_spec(lhs,max_offset(cur_pen),internal[tracing_specs]); 20395 rev_turns:=false; 20396 if max_offset(cur_pen)=0 then fill_spec(lhs) 20397 else fill_envelope(lhs); 20398 end; 20399not_found: end 20400 20401@ @<Double the path@>= 20402if link(rhs)=rhs then @<Make a trivial one-point path cycle@> 20403else begin p:=htap_ypoc(rhs); q:=link(p);@/ 20404 right_x(path_tail):=right_x(q); right_y(path_tail):=right_y(q); 20405 right_type(path_tail):=right_type(q); 20406 link(path_tail):=link(q); free_node(q,knot_node_size);@/ 20407 right_x(p):=right_x(rhs); right_y(p):=right_y(rhs); 20408 right_type(p):=right_type(rhs); 20409 link(p):=link(rhs); free_node(rhs,knot_node_size);@/ 20410 rhs:=p; 20411 end 20412 20413@ @<Make a trivial one-point path cycle@>= 20414begin right_x(rhs):=x_coord(rhs); right_y(rhs):=y_coord(rhs); 20415left_x(rhs):=x_coord(rhs); left_y(rhs):=y_coord(rhs); 20416left_type(rhs):=explicit; right_type(rhs):=explicit; 20417end 20418 20419@ @<Complain about non-cycle...@>= 20420begin print_err("Not a cycle"); 20421@.Not a cycle@> 20422help2("That contour should have ended with `..cycle' or `&cycle'.")@/ 20423 ("So I'll not change anything just now."); put_get_error; 20424toss_knot_list(rhs); goto not_found; 20425end 20426 20427@ @<Check the turning number@>= 20428if turning_number<=0 then 20429 if cur_path_type<>double_path_code then if internal[turning_check]>0 then 20430 if (turning_number<0)and(link(cur_pen)=null) then negate(cur_wt) 20431 else begin if turning_number=0 then 20432 if (internal[turning_check]<=unity)and(link(cur_pen)=null) then goto done 20433 else print_strange("Strange path (turning number is zero)") 20434@.Strange path...@> 20435 else print_strange("Backwards path (turning number is negative)"); 20436@.Backwards path...@> 20437 help3("The path doesn't have a counterclockwise orientation,")@/ 20438 ("so I'll probably have trouble drawing it.")@/ 20439 ("(See Chapter 27 of The METAFONTbook for more help.)"); 20440@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 20441 put_get_error; 20442 end; 20443done: 20444 20445@ @<Cases of |do_statement|...@>= 20446ship_out_command: do_ship_out; 20447display_command: do_display; 20448open_window: do_open_window; 20449cull_command: do_cull; 20450 20451@ @<Declare action procedures for use by |do_statement|@>= 20452@t\4@>@<Declare the function called |tfm_check|@>@; 20453procedure do_ship_out; 20454label exit; 20455var @!c:integer; {the character code} 20456begin get_x_next; var_flag:=semicolon; scan_expression; 20457if cur_type<>token_list then 20458 if cur_type=picture_type then cur_edges:=cur_exp 20459 else begin @<Abandon edges command because there's no variable@>; 20460 return; 20461 end 20462else begin find_edges_var(cur_exp); cur_type:=vacuous; 20463 end; 20464if cur_edges<>null then 20465 begin c:=round_unscaled(internal[char_code]) mod 256; 20466 if c<0 then c:=c+256; 20467 @<Store the width information for character code~|c|@>; 20468 if internal[proofing]>=0 then ship_out(c); 20469 end; 20470flush_cur_exp(0); 20471exit:end; 20472 20473@ @<Declare action procedures for use by |do_statement|@>= 20474procedure do_display; 20475label not_found,common_ending,exit; 20476var @!e:pointer; {token list for a picture variable} 20477begin get_x_next; var_flag:=in_window; scan_primary; 20478if cur_type<>token_list then 20479 @<Abandon edges command because there's no variable@> 20480else begin e:=cur_exp; cur_type:=vacuous; 20481 get_x_next; scan_expression; 20482 if cur_type<>known then goto common_ending; 20483 cur_exp:=round_unscaled(cur_exp); 20484 if cur_exp<0 then goto not_found; 20485 if cur_exp>15 then goto not_found; 20486 if not window_open[cur_exp] then goto not_found; 20487 find_edges_var(e); 20488 if cur_edges<>null then disp_edges(cur_exp); 20489 return; 20490 not_found: cur_exp:=cur_exp*unity; 20491 common_ending: exp_err("Bad window number"); 20492@.Bad window number@> 20493 help1("It should be the number of an open window."); 20494 put_get_flush_error(0); flush_token_list(e); 20495 end; 20496exit:end; 20497 20498@ The only thing difficult about `\&{openwindow}' is that the syntax 20499allows the user to go astray in many ways. The following subroutine 20500helps keep the necessary program reasonably short and sweet. 20501 20502@<Declare action procedures for use by |do_statement|@>= 20503function get_pair(@!c:command_code):boolean; 20504var @!p:pointer; {a pair of values that are known (we hope)} 20505@!b:boolean; {did we find such a pair?} 20506begin if cur_cmd<>c then get_pair:=false 20507else begin get_x_next; scan_expression; 20508 if nice_pair(cur_exp,cur_type) then 20509 begin p:=value(cur_exp); 20510 cur_x:=value(x_part_loc(p)); cur_y:=value(y_part_loc(p)); 20511 b:=true; 20512 end 20513 else b:=false; 20514 flush_cur_exp(0); get_pair:=b; 20515 end; 20516end; 20517 20518@ @<Declare action procedures for use by |do_statement|@>= 20519procedure do_open_window; 20520label not_found,exit; 20521var @!k:integer; {the window number in question} 20522@!r0,@!c0,@!r1,@!c1:scaled; {window coordinates} 20523begin get_x_next; scan_expression; 20524if cur_type<>known then goto not_found; 20525k:=round_unscaled(cur_exp); 20526if k<0 then goto not_found; 20527if k>15 then goto not_found; 20528if not get_pair(from_token) then goto not_found; 20529r0:=cur_x; c0:=cur_y; 20530if not get_pair(to_token) then goto not_found; 20531r1:=cur_x; c1:=cur_y; 20532if not get_pair(at_token) then goto not_found; 20533open_a_window(k,r0,c0,r1,c1,cur_x,cur_y); return; 20534not_found:print_err("Improper `openwindow'"); 20535@.Improper `openwindow'@> 20536help2("Say `openwindow k from (r0,c0) to (r1,c1) at (x,y)',")@/ 20537 ("where all quantities are known and k is between 0 and 15."); 20538put_get_error; 20539exit:end; 20540 20541@ @<Declare action procedures for use by |do_statement|@>= 20542procedure do_cull; 20543label not_found,exit; 20544var @!e:pointer; {token list for a picture variable} 20545@!keeping:drop_code..keep_code; {modifier of |cull_op|} 20546@!w,@!w_in,@!w_out:integer; {culling weights} 20547begin w:=1; 20548get_x_next; var_flag:=cull_op; scan_primary; 20549if cur_type<>token_list then 20550 @<Abandon edges command because there's no variable@> 20551else begin e:=cur_exp; cur_type:=vacuous; keeping:=cur_mod; 20552 if not get_pair(cull_op) then goto not_found; 20553 while (cur_cmd=with_option)and(cur_mod=known) do 20554 if scan_with then w:=cur_exp; 20555 @<Set up the culling weights, 20556 or |goto not_found| if the thresholds are bad@>; 20557 find_edges_var(e); 20558 if cur_edges<>null then 20559 cull_edges(floor_unscaled(cur_x+unity-1),floor_unscaled(cur_y),w_out,w_in); 20560 return; 20561 not_found: print_err("Bad culling amounts"); 20562@.Bad culling amounts@> 20563 help1("Always cull by known amounts that exclude 0."); 20564 put_get_error; flush_token_list(e); 20565 end; 20566exit:end; 20567 20568@ @<Set up the culling weights, or |goto not_found| if the thresholds are bad@>= 20569if cur_x>cur_y then goto not_found; 20570if keeping=drop_code then 20571 begin if (cur_x>0)or(cur_y<0) then goto not_found; 20572 w_out:=w; w_in:=0; 20573 end 20574else begin if (cur_x<=0)and(cur_y>=0) then goto not_found; 20575 w_out:=0; w_in:=w; 20576 end 20577 20578@ The \&{everyjob} command simply assigns a nonzero value to the global variable 20579|start_sym|. 20580 20581@<Cases of |do_statement|...@>= 20582every_job_command: begin get_symbol; start_sym:=cur_sym; get_x_next; 20583 end; 20584 20585@ @<Glob...@>= 20586@!start_sym:halfword; {a symbolic token to insert at beginning of job} 20587 20588@ @<Set init...@>= 20589start_sym:=0; 20590 20591@ Finally, we have only the ``message'' commands remaining. 20592 20593@d message_code=0 20594@d err_message_code=1 20595@d err_help_code=2 20596 20597@<Put each...@>= 20598primitive("message",message_command,message_code);@/ 20599@!@:message_}{\&{message} primitive@> 20600primitive("errmessage",message_command,err_message_code);@/ 20601@!@:err_message_}{\&{errmessage} primitive@> 20602primitive("errhelp",message_command,err_help_code);@/ 20603@!@:err_help_}{\&{errhelp} primitive@> 20604 20605@ @<Cases of |print_cmd...@>= 20606message_command: if m<err_message_code then print("message") 20607 else if m=err_message_code then print("errmessage") 20608 else print("errhelp"); 20609 20610@ @<Cases of |do_statement|...@>= 20611message_command: do_message; 20612 20613@ @<Declare action procedures for use by |do_statement|@>= 20614procedure do_message; 20615var @!m:message_code..err_help_code; {the type of message} 20616begin m:=cur_mod; get_x_next; scan_expression; 20617if cur_type<>string_type then 20618 begin exp_err("Not a string"); 20619@.Not a string@> 20620 help1("A message should be a known string expression."); 20621 put_get_error; 20622 end 20623else case m of 20624 message_code:begin print_nl(""); slow_print(cur_exp); 20625 end; 20626 err_message_code:@<Print string |cur_exp| as an error message@>; 20627 err_help_code:@<Save string |cur_exp| as the |err_help|@>; 20628 end; {there are no other cases} 20629flush_cur_exp(0); 20630end; 20631 20632@ The global variable |err_help| is zero when the user has most recently 20633given an empty help string, or if none has ever been given. 20634 20635@<Save string |cur_exp| as the |err_help|@>= 20636begin if err_help<>0 then delete_str_ref(err_help); 20637if length(cur_exp)=0 then err_help:=0 20638else begin err_help:=cur_exp; add_str_ref(err_help); 20639 end; 20640end 20641 20642@ If \&{errmessage} occurs often in |scroll_mode|, without user-defined 20643\&{errhelp}, we don't want to give a long help message each time. So we 20644give a verbose explanation only once. 20645 20646@<Glob...@>= 20647@!long_help_seen:boolean; {has the long \&{errmessage} help been used?} 20648 20649@ @<Set init...@>=long_help_seen:=false; 20650 20651@ @<Print string |cur_exp| as an error message@>= 20652begin print_err(""); slow_print(cur_exp); 20653if err_help<>0 then use_err_help:=true 20654else if long_help_seen then help1("(That was another `errmessage'.)") 20655else begin if interaction<error_stop_mode then long_help_seen:=true; 20656 help4("This error message was generated by an `errmessage'")@/ 20657 ("command, so I can't give any explicit help.")@/ 20658 ("Pretend that you're Miss Marple: Examine all clues,")@/ 20659@^Marple, Jane@> 20660 ("and deduce the truth by inspired guesses."); 20661 end; 20662put_get_error; use_err_help:=false; 20663end 20664 20665@* \[45] Font metric data. 20666\TeX\ gets its knowledge about fonts from font metric files, also called 20667\.{TFM} files; the `\.T' in `\.{TFM}' stands for \TeX, 20668but other programs know about them too. One of \MF's duties is to 20669write \.{TFM} files so that the user's fonts can readily be 20670applied to typesetting. 20671@:TFM files}{\.{TFM} files@> 20672@^font metric files@> 20673 20674The information in a \.{TFM} file appears in a sequence of 8-bit bytes. 20675Since the number of bytes is always a multiple of~4, we could 20676also regard the file as a sequence of 32-bit words, but \MF\ uses the 20677byte interpretation. The format of \.{TFM} files was designed by 20678Lyle Ramshaw in 1980. The intent is to convey a lot of different kinds 20679@^Ramshaw, Lyle Harold@> 20680of information in a compact but useful form. 20681 20682@<Glob...@>= 20683@!tfm_file:byte_file; {the font metric output goes here} 20684@!metric_file_name: str_number; {full name of the font metric file} 20685 20686@ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit 20687integers that give the lengths of the various subsequent portions 20688of the file. These twelve integers are, in order: 20689$$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr 20690|lf|&length of the entire file, in words;\cr 20691|lh|&length of the header data, in words;\cr 20692|bc|&smallest character code in the font;\cr 20693|ec|&largest character code in the font;\cr 20694|nw|&number of words in the width table;\cr 20695|nh|&number of words in the height table;\cr 20696|nd|&number of words in the depth table;\cr 20697|ni|&number of words in the italic correction table;\cr 20698|nl|&number of words in the lig/kern table;\cr 20699|nk|&number of words in the kern table;\cr 20700|ne|&number of words in the extensible character table;\cr 20701|np|&number of font parameter words.\cr}}$$ 20702They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|, 20703|ne<=256|, and 20704$$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$ 20705Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|), 20706and as few as 0 characters (if |bc=ec+1|). 20707 20708Incidentally, when two or more 8-bit bytes are combined to form an integer of 2070916 or more bits, the most significant bytes appear first in the file. 20710This is called BigEndian order. 20711@!@^BigEndian order@> 20712 20713@ The rest of the \.{TFM} file may be regarded as a sequence of ten data 20714arrays having the informal specification 20715$$\def\arr$[#1]#2${\&{array} $[#1]$ \&{of} #2} 20716\tabskip\centering 20717\halign to\displaywidth{\hfil\\{#}\tabskip=0pt&$\,:\,$\arr#\hfil 20718 \tabskip\centering\cr 20719header&|[0..lh-1]@t\\{stuff}@>|\cr 20720char\_info&|[bc..ec]char_info_word|\cr 20721width&|[0..nw-1]fix_word|\cr 20722height&|[0..nh-1]fix_word|\cr 20723depth&|[0..nd-1]fix_word|\cr 20724italic&|[0..ni-1]fix_word|\cr 20725lig\_kern&|[0..nl-1]lig_kern_command|\cr 20726kern&|[0..nk-1]fix_word|\cr 20727exten&|[0..ne-1]extensible_recipe|\cr 20728param&|[1..np]fix_word|\cr}$$ 20729The most important data type used here is a |@!fix_word|, which is 20730a 32-bit representation of a binary fraction. A |fix_word| is a signed 20731quantity, with the two's complement of the entire word used to represent 20732negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the 20733binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and 20734the smallest is $-2048$. We will see below, however, that all but two of 20735the |fix_word| values must lie between $-16$ and $+16$. 20736 20737@ The first data array is a block of header information, which contains 20738general facts about the font. The header must contain at least two words, 20739|header[0]| and |header[1]|, whose meaning is explained below. Additional 20740header information of use to other software routines might also be 20741included, and \MF\ will generate it if the \.{headerbyte} command occurs. 20742For example, 16 more words of header information are in use at the Xerox 20743Palo Alto Research Center; the first ten specify the character coding 20744scheme used (e.g., `\.{XEROX TEXT}' or `\.{TEX MATHSY}'), the next five 20745give the font family name (e.g., `\.{HELVETICA}' or `\.{CMSY}'), and the 20746last gives the ``face byte.'' 20747 20748\yskip\hang|header[0]| is a 32-bit check sum that \MF\ will copy into 20749the \.{GF} output file. This helps ensure consistency between files, 20750since \TeX\ records the check sums from the \.{TFM}'s it reads, and these 20751should match the check sums on actual fonts that are used. The actual 20752relation between this check sum and the rest of the \.{TFM} file is not 20753important; the check sum is simply an identification number with the 20754property that incompatible fonts almost always have distinct check sums. 20755@^check sum@> 20756 20757\yskip\hang|header[1]| is a |fix_word| containing the design size of the 20758font, in units of \TeX\ points. This number must be at least 1.0; it is 20759fairly arbitrary, but usually the design size is 10.0 for a ``10 point'' 20760font, i.e., a font that was designed to look best at a 10-point size, 20761whatever that really means. When a \TeX\ user asks for a font `\.{at} 20762$\delta$ \.{pt}', the effect is to override the design size and replace it 20763by $\delta$, and to multiply the $x$ and~$y$ coordinates of the points in 20764the font image by a factor of $\delta$ divided by the design size. {\sl 20765All other dimensions in the\/ \.{TFM} file are |fix_word|\kern-1pt\ 20766numbers in design-size units.} Thus, for example, the value of |param[6]|, 20767which defines the \.{em} unit, is often the |fix_word| value $2^{20}=1.0$, 20768since many fonts have a design size equal to one em. The other dimensions 20769must be less than 16 design-size units in absolute value; thus, 20770|header[1]| and |param[1]| are the only |fix_word| entries in the whole 20771\.{TFM} file whose first byte might be something besides 0 or 255. 20772@^design size@> 20773 20774@ Next comes the |char_info| array, which contains one |@!char_info_word| 20775per character. Each word in this part of the file contains six fields 20776packed into four bytes as follows. 20777 20778\yskip\hang first byte: |@!width_index| (8 bits)\par 20779\hang second byte: |@!height_index| (4 bits) times 16, plus |@!depth_index| 20780 (4~bits)\par 20781\hang third byte: |@!italic_index| (6 bits) times 4, plus |@!tag| 20782 (2~bits)\par 20783\hang fourth byte: |@!remainder| (8 bits)\par 20784\yskip\noindent 20785The actual width of a character is \\{width}|[width_index]|, in design-size 20786units; this is a device for compressing information, since many characters 20787have the same width. Since it is quite common for many characters 20788to have the same height, depth, or italic correction, the \.{TFM} format 20789imposes a limit of 16 different heights, 16 different depths, and 2079064 different italic corrections. 20791 20792Incidentally, the relation $\\{width}[0]=\\{height}[0]=\\{depth}[0]= 20793\\{italic}[0]=0$ should always hold, so that an index of zero implies a 20794value of zero. The |width_index| should never be zero unless the 20795character does not exist in the font, since a character is valid if and 20796only if it lies between |bc| and |ec| and has a nonzero |width_index|. 20797 20798@ The |tag| field in a |char_info_word| has four values that explain how to 20799interpret the |remainder| field. 20800 20801\def\hangg#1 {\hang\hbox{#1 }} 20802\yskip\hangg|tag=0| (|no_tag|) means that |remainder| is unused.\par 20803\hangg|tag=1| (|lig_tag|) means that this character has a ligature/kerning 20804program starting at location |remainder| in the |lig_kern| array.\par 20805\hangg|tag=2| (|list_tag|) means that this character is part of a chain of 20806characters of ascending sizes, and not the largest in the chain. The 20807|remainder| field gives the character code of the next larger character.\par 20808\hangg|tag=3| (|ext_tag|) means that this character code represents an 20809extensible character, i.e., a character that is built up of smaller pieces 20810so that it can be made arbitrarily large. The pieces are specified in 20811|@!exten[remainder]|.\par 20812\yskip\noindent 20813Characters with |tag=2| and |tag=3| are treated as characters with |tag=0| 20814unless they are used in special circumstances in math formulas. For example, 20815\TeX's \.{\\sum} operation looks for a |list_tag|, and the \.{\\left} 20816operation looks for both |list_tag| and |ext_tag|. 20817 20818@d no_tag=0 {vanilla character} 20819@d lig_tag=1 {character has a ligature/kerning program} 20820@d list_tag=2 {character has a successor in a charlist} 20821@d ext_tag=3 {character is extensible} 20822 20823@ The |lig_kern| array contains instructions in a simple programming language 20824that explains what to do for special letter pairs. Each word in this array is a 20825|@!lig_kern_command| of four bytes. 20826 20827\yskip\hang first byte: |skip_byte|, indicates that this is the final program 20828 step if the byte is 128 or more, otherwise the next step is obtained by 20829 skipping this number of intervening steps.\par 20830\hang second byte: |next_char|, ``if |next_char| follows the current character, 20831 then perform the operation and stop, otherwise continue.''\par 20832\hang third byte: |op_byte|, indicates a ligature step if less than~128, 20833 a kern step otherwise.\par 20834\hang fourth byte: |remainder|.\par 20835\yskip\noindent 20836In a kern step, an 20837additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted 20838between the current character and |next_char|. This amount is 20839often negative, so that the characters are brought closer together 20840by kerning; but it might be positive. 20841 20842There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where 20843$0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is 20844|remainder| is inserted between the current character and |next_char|; 20845then the current character is deleted if $b=0$, and |next_char| is 20846deleted if $c=0$; then we pass over $a$~characters to reach the next 20847current character (which may have a ligature/kerning program of its own). 20848 20849If the very first instruction of the |lig_kern| array has |skip_byte=255|, 20850the |next_char| byte is the so-called right boundary character of this font; 20851the value of |next_char| need not lie between |bc| and~|ec|. 20852If the very last instruction of the |lig_kern| array has |skip_byte=255|, 20853there is a special ligature/kerning program for a left boundary character, 20854beginning at location |256*op_byte+remainder|. 20855The interpretation is that \TeX\ puts implicit boundary characters 20856before and after each consecutive string of characters from the same font. 20857These implicit characters do not appear in the output, but they can affect 20858ligatures and kerning. 20859 20860If the very first instruction of a character's |lig_kern| program has 20861|skip_byte>128|, the program actually begins in location 20862|256*op_byte+remainder|. This feature allows access to large |lig_kern| 20863arrays, because the first instruction must otherwise 20864appear in a location |<=255|. 20865 20866Any instruction with |skip_byte>128| in the |lig_kern| array must satisfy 20867the condition 20868$$\hbox{|256*op_byte+remainder<nl|.}$$ 20869If such an instruction is encountered during 20870normal program execution, it denotes an unconditional halt; no ligature 20871command is performed. 20872 20873@d stop_flag=128+min_quarterword 20874 {value indicating `\.{STOP}' in a lig/kern program} 20875@d kern_flag=128+min_quarterword {op code for a kern step} 20876@d skip_byte(#)==lig_kern[#].b0 20877@d next_char(#)==lig_kern[#].b1 20878@d op_byte(#)==lig_kern[#].b2 20879@d rem_byte(#)==lig_kern[#].b3 20880 20881@ Extensible characters are specified by an |@!extensible_recipe|, which 20882consists of four bytes called |@!top|, |@!mid|, |@!bot|, and |@!rep| (in this 20883order). These bytes are the character codes of individual pieces used to 20884build up a large symbol. If |top|, |mid|, or |bot| are zero, they are not 20885present in the built-up result. For example, an extensible vertical line is 20886like an extensible bracket, except that the top and bottom pieces are missing. 20887 20888Let $T$, $M$, $B$, and $R$ denote the respective pieces, or an empty box 20889if the piece isn't present. Then the extensible characters have the form 20890$TR^kMR^kB$ from top to bottom, for some |k>=0|, unless $M$ is absent; 20891in the latter case we can have $TR^kB$ for both even and odd values of~|k|. 20892The width of the extensible character is the width of $R$; and the 20893height-plus-depth is the sum of the individual height-plus-depths of the 20894components used, since the pieces are butted together in a vertical list. 20895 20896@d ext_top(#)==exten[#].b0 {|top| piece in a recipe} 20897@d ext_mid(#)==exten[#].b1 {|mid| piece in a recipe} 20898@d ext_bot(#)==exten[#].b2 {|bot| piece in a recipe} 20899@d ext_rep(#)==exten[#].b3 {|rep| piece in a recipe} 20900 20901@ The final portion of a \.{TFM} file is the |param| array, which is another 20902sequence of |fix_word| values. 20903 20904\yskip\hang|param[1]=slant| is the amount of italic slant, which is used 20905to help position accents. For example, |slant=.25| means that when you go 20906up one unit, you also go .25 units to the right. The |slant| is a pure 20907number; it is the only |fix_word| other than the design size itself that is 20908not scaled by the design size. 20909@^design size@> 20910 20911\hang|param[2]=space| is the normal spacing between words in text. 20912Note that character @'40 in the font need not have anything to do with 20913blank spaces. 20914 20915\hang|param[3]=space_stretch| is the amount of glue stretching between words. 20916 20917\hang|param[4]=space_shrink| is the amount of glue shrinking between words. 20918 20919\hang|param[5]=x_height| is the size of one ex in the font; it is also 20920the height of letters for which accents don't have to be raised or lowered. 20921 20922\hang|param[6]=quad| is the size of one em in the font. 20923 20924\hang|param[7]=extra_space| is the amount added to |param[2]| at the 20925ends of sentences. 20926 20927\yskip\noindent 20928If fewer than seven parameters are present, \TeX\ sets the missing parameters 20929to zero. 20930 20931@d slant_code=1 20932@d space_code=2 20933@d space_stretch_code=3 20934@d space_shrink_code=4 20935@d x_height_code=5 20936@d quad_code=6 20937@d extra_space_code=7 20938 20939@ So that is what \.{TFM} files hold. One of \MF's duties is to output such 20940information, and it does this all at once at the end of a job. 20941In order to prepare for such frenetic activity, it squirrels away the 20942necessary facts in various arrays as information becomes available. 20943 20944Character dimensions (\&{charwd}, \&{charht}, \&{chardp}, and \&{charic}) 20945are stored respectively in |tfm_width|, |tfm_height|, |tfm_depth|, and 20946|tfm_ital_corr|. Other information about a character (e.g., about 20947its ligatures or successors) is accessible via the |char_tag| and 20948|char_remainder| arrays. Other information about the font as a whole 20949is kept in additional arrays called |header_byte|, |lig_kern|, 20950|kern|, |exten|, and |param|. 20951 20952@d undefined_label==lig_table_size {an undefined local label} 20953 20954@<Glob...@>= 20955@!bc,@!ec:eight_bits; {smallest and largest character codes shipped out} 20956@!tfm_width:array[eight_bits] of scaled; {\&{charwd} values} 20957@!tfm_height:array[eight_bits] of scaled; {\&{charht} values} 20958@!tfm_depth:array[eight_bits] of scaled; {\&{chardp} values} 20959@!tfm_ital_corr:array[eight_bits] of scaled; {\&{charic} values} 20960@!char_exists:array[eight_bits] of boolean; {has this code been shipped out?} 20961@!char_tag:array[eight_bits] of no_tag..ext_tag; {|remainder| category} 20962@!char_remainder:array[eight_bits] of 0..lig_table_size; {the |remainder| byte} 20963@!header_byte:array[1..header_size] of -1..255; 20964 {bytes of the \.{TFM} header, or $-1$ if unset} 20965@!lig_kern:array[0..lig_table_size] of four_quarters; {the ligature/kern table} 20966@!nl:0..32767-256; {the number of ligature/kern steps so far} 20967@!kern:array[0..max_kerns] of scaled; {distinct kerning amounts} 20968@!nk:0..max_kerns; {the number of distinct kerns so far} 20969@!exten:array[eight_bits] of four_quarters; {extensible character recipes} 20970@!ne:0..256; {the number of extensible characters so far} 20971@!param:array[1..max_font_dimen] of scaled; {\&{fontinfo} parameters} 20972@!np:0..max_font_dimen; {the largest \&{fontinfo} parameter specified so far} 20973@!nw,@!nh,@!nd,@!ni:0..256; {sizes of \.{TFM} subtables} 20974@!skip_table:array[eight_bits] of 0..lig_table_size; {local label status} 20975@!lk_started:boolean; {has there been a lig/kern step in this command yet?} 20976@!bchar:integer; {right boundary character} 20977@!bch_label:0..lig_table_size; {left boundary starting location} 20978@!ll,@!lll:0..lig_table_size; {registers used for lig/kern processing} 20979@!label_loc:array[0..256] of -1..lig_table_size; {lig/kern starting addresses} 20980@!label_char:array[1..256] of eight_bits; {characters for |label_loc|} 20981@!label_ptr:0..256; {highest position occupied in |label_loc|} 20982 20983@ @<Set init...@>= 20984for k:=0 to 255 do 20985 begin tfm_width[k]:=0; tfm_height[k]:=0; tfm_depth[k]:=0; tfm_ital_corr[k]:=0; 20986 char_exists[k]:=false; char_tag[k]:=no_tag; char_remainder[k]:=0; 20987 skip_table[k]:=undefined_label; 20988 end; 20989for k:=1 to header_size do header_byte[k]:=-1; 20990bc:=255; ec:=0; nl:=0; nk:=0; ne:=0; np:=0;@/ 20991internal[boundary_char]:=-unity; 20992bch_label:=undefined_label;@/ 20993label_loc[0]:=-1; label_ptr:=0; 20994 20995@ @<Declare the function called |tfm_check|@>= 20996function tfm_check(@!m:small_number):scaled; 20997begin if abs(internal[m])>=fraction_half then 20998 begin print_err("Enormous "); print(int_name[m]); 20999@.Enormous charwd...@> 21000@.Enormous chardp...@> 21001@.Enormous charht...@> 21002@.Enormous charic...@> 21003@.Enormous designsize...@> 21004 print(" has been reduced"); 21005 help1("Font metric dimensions must be less than 2048pt."); 21006 put_get_error; 21007 if internal[m]>0 then tfm_check:=fraction_half-1 21008 else tfm_check:=1-fraction_half; 21009 end 21010else tfm_check:=internal[m]; 21011end; 21012 21013@ @<Store the width information for character code~|c|@>= 21014if c<bc then bc:=c; 21015if c>ec then ec:=c; 21016char_exists[c]:=true; 21017gf_dx[c]:=internal[char_dx]; gf_dy[c]:=internal[char_dy]; 21018tfm_width[c]:=tfm_check(char_wd); 21019tfm_height[c]:=tfm_check(char_ht); 21020tfm_depth[c]:=tfm_check(char_dp); 21021tfm_ital_corr[c]:=tfm_check(char_ic) 21022 21023@ Now let's consider \MF's special \.{TFM}-oriented commands. 21024 21025@<Cases of |do_statement|...@>= 21026tfm_command: do_tfm_command; 21027 21028@ @d char_list_code=0 21029@d lig_table_code=1 21030@d extensible_code=2 21031@d header_byte_code=3 21032@d font_dimen_code=4 21033 21034@<Put each...@>= 21035primitive("charlist",tfm_command,char_list_code);@/ 21036@!@:char_list_}{\&{charlist} primitive@> 21037primitive("ligtable",tfm_command,lig_table_code);@/ 21038@!@:lig_table_}{\&{ligtable} primitive@> 21039primitive("extensible",tfm_command,extensible_code);@/ 21040@!@:extensible_}{\&{extensible} primitive@> 21041primitive("headerbyte",tfm_command,header_byte_code);@/ 21042@!@:header_byte_}{\&{headerbyte} primitive@> 21043primitive("fontdimen",tfm_command,font_dimen_code);@/ 21044@!@:font_dimen_}{\&{fontdimen} primitive@> 21045 21046@ @<Cases of |print_cmd...@>= 21047tfm_command: case m of 21048 char_list_code:print("charlist"); 21049 lig_table_code:print("ligtable"); 21050 extensible_code:print("extensible"); 21051 header_byte_code:print("headerbyte"); 21052 othercases print("fontdimen") 21053 endcases; 21054 21055@ @<Declare action procedures for use by |do_statement|@>= 21056function get_code:eight_bits; {scans a character code value} 21057label found; 21058var @!c:integer; {the code value found} 21059begin get_x_next; scan_expression; 21060if cur_type=known then 21061 begin c:=round_unscaled(cur_exp); 21062 if c>=0 then if c<256 then goto found; 21063 end 21064else if cur_type=string_type then if length(cur_exp)=1 then 21065 begin c:=so(str_pool[str_start[cur_exp]]); goto found; 21066 end; 21067exp_err("Invalid code has been replaced by 0"); 21068@.Invalid code...@> 21069help2("I was looking for a number between 0 and 255, or for a")@/ 21070 ("string of length 1. Didn't find it; will use 0 instead."); 21071put_get_flush_error(0); c:=0; 21072found: get_code:=c; 21073end; 21074 21075@ @<Declare action procedures for use by |do_statement|@>= 21076procedure set_tag(@!c:halfword;@!t:small_number;@!r:halfword); 21077begin if char_tag[c]=no_tag then 21078 begin char_tag[c]:=t; char_remainder[c]:=r; 21079 if t=lig_tag then 21080 begin incr(label_ptr); label_loc[label_ptr]:=r; label_char[label_ptr]:=c; 21081 end; 21082 end 21083else @<Complain about a character tag conflict@>; 21084end; 21085 21086@ @<Complain about a character tag conflict@>= 21087begin print_err("Character "); 21088if (c>" ")and(c<127) then print(c) 21089else if c=256 then print("||") 21090else begin print("code "); print_int(c); 21091 end; 21092print(" is already "); 21093@.Character c is already...@> 21094case char_tag[c] of 21095lig_tag: print("in a ligtable"); 21096list_tag: print("in a charlist"); 21097ext_tag: print("extensible"); 21098end; {there are no other cases} 21099help2("It's not legal to label a character more than once.")@/ 21100 ("So I'll not change anything just now."); 21101put_get_error; end 21102 21103@ @<Declare action procedures for use by |do_statement|@>= 21104procedure do_tfm_command; 21105label continue,done; 21106var @!c,@!cc:0..256; {character codes} 21107@!k:0..max_kerns; {index into the |kern| array} 21108@!j:integer; {index into |header_byte| or |param|} 21109begin case cur_mod of 21110char_list_code: begin c:=get_code; 21111 {we will store a list of character successors} 21112 while cur_cmd=colon do 21113 begin cc:=get_code; set_tag(c,list_tag,cc); c:=cc; 21114 end; 21115 end; 21116lig_table_code: @<Store a list of ligature/kern steps@>; 21117extensible_code: @<Define an extensible recipe@>; 21118header_byte_code, font_dimen_code: begin c:=cur_mod; get_x_next; 21119 scan_expression; 21120 if (cur_type<>known)or(cur_exp<half_unit) then 21121 begin exp_err("Improper location"); 21122@.Improper location@> 21123 help2("I was looking for a known, positive number.")@/ 21124 ("For safety's sake I'll ignore the present command."); 21125 put_get_error; 21126 end 21127 else begin j:=round_unscaled(cur_exp); 21128 if cur_cmd<>colon then 21129 begin missing_err(":"); 21130@.Missing `:'@> 21131 help1("A colon should follow a headerbyte or fontinfo location."); 21132 back_error; 21133 end; 21134 if c=header_byte_code then @<Store a list of header bytes@> 21135 else @<Store a list of font dimensions@>; 21136 end; 21137 end; 21138end; {there are no other cases} 21139end; 21140 21141@ @<Store a list of ligature/kern steps@>= 21142begin lk_started:=false; 21143continue: get_x_next; 21144if(cur_cmd=skip_to)and lk_started then 21145 @<Process a |skip_to| command and |goto done|@>; 21146if cur_cmd=bchar_label then 21147 begin c:=256; cur_cmd:=colon;@+end 21148else begin back_input; c:=get_code;@+end; 21149if(cur_cmd=colon)or(cur_cmd=double_colon)then 21150 @<Record a label in a lig/kern subprogram and |goto continue|@>; 21151if cur_cmd=lig_kern_token then @<Compile a ligature/kern command@> 21152else begin print_err("Illegal ligtable step"); 21153@.Illegal ligtable step@> 21154 help1("I was looking for `=:' or `kern' here."); 21155 back_error; next_char(nl):=qi(0); op_byte(nl):=qi(0); rem_byte(nl):=qi(0);@/ 21156 skip_byte(nl):=stop_flag+1; {this specifies an unconditional stop} 21157 end; 21158if nl=lig_table_size then overflow("ligtable size",lig_table_size); 21159@:METAFONT capacity exceeded ligtable size}{\quad ligtable size@> 21160incr(nl); 21161if cur_cmd=comma then goto continue; 21162if skip_byte(nl-1)<stop_flag then skip_byte(nl-1):=stop_flag; 21163done:end 21164 21165@ @<Put each...@>= 21166primitive("=:",lig_kern_token,0); 21167@!@:=:_}{\.{=:} primitive@> 21168primitive("=:|",lig_kern_token,1); 21169@!@:=:/_}{\.{=:\char'174} primitive@> 21170primitive("=:|>",lig_kern_token,5); 21171@!@:=:/>_}{\.{=:\char'174>} primitive@> 21172primitive("|=:",lig_kern_token,2); 21173@!@:=:/_}{\.{\char'174=:} primitive@> 21174primitive("|=:>",lig_kern_token,6); 21175@!@:=:/>_}{\.{\char'174=:>} primitive@> 21176primitive("|=:|",lig_kern_token,3); 21177@!@:=:/_}{\.{\char'174=:\char'174} primitive@> 21178primitive("|=:|>",lig_kern_token,7); 21179@!@:=:/>_}{\.{\char'174=:\char'174>} primitive@> 21180primitive("|=:|>>",lig_kern_token,11); 21181@!@:=:/>_}{\.{\char'174=:\char'174>>} primitive@> 21182primitive("kern",lig_kern_token,128); 21183@!@:kern_}{\&{kern} primitive@> 21184 21185@ @<Cases of |print_cmd...@>= 21186lig_kern_token: case m of 211870:print("=:"); 211881:print("=:|"); 211892:print("|=:"); 211903:print("|=:|"); 211915:print("=:|>"); 211926:print("|=:>"); 211937:print("|=:|>"); 2119411:print("|=:|>>"); 21195othercases print("kern") 21196endcases; 21197 21198@ Local labels are implemented by maintaining the |skip_table| array, 21199where |skip_table[c]| is either |undefined_label| or the address of the 21200most recent lig/kern instruction that skips to local label~|c|. In the 21201latter case, the |skip_byte| in that instruction will (temporarily) 21202be zero if there were no prior skips to this label, or it will be the 21203distance to the prior skip. 21204 21205We may need to cancel skips that span more than 127 lig/kern steps. 21206 21207@d cancel_skips(#)==ll:=#; 21208 repeat lll:=qo(skip_byte(ll)); skip_byte(ll):=stop_flag; ll:=ll-lll; 21209 until lll=0 21210@d skip_error(#)==begin print_err("Too far to skip"); 21211@.Too far to skip@> 21212 help1("At most 127 lig/kern steps can separate skipto1 from 1::."); 21213 error; cancel_skips(#); 21214 end 21215 21216@<Process a |skip_to| command and |goto done|@>= 21217begin c:=get_code; 21218if nl-skip_table[c]>128 then 21219 begin skip_error(skip_table[c]); skip_table[c]:=undefined_label; 21220 end; 21221if skip_table[c]=undefined_label then skip_byte(nl-1):=qi(0) 21222else skip_byte(nl-1):=qi(nl-skip_table[c]-1); 21223skip_table[c]:=nl-1; goto done; 21224end 21225 21226@ @<Record a label in a lig/kern subprogram and |goto continue|@>= 21227begin if cur_cmd=colon then 21228 if c=256 then bch_label:=nl 21229 else set_tag(c,lig_tag,nl) 21230else if skip_table[c]<undefined_label then 21231 begin ll:=skip_table[c]; skip_table[c]:=undefined_label; 21232 repeat lll:=qo(skip_byte(ll)); 21233 if nl-ll>128 then 21234 begin skip_error(ll); goto continue; 21235 end; 21236 skip_byte(ll):=qi(nl-ll-1); ll:=ll-lll; 21237 until lll=0; 21238 end; 21239goto continue; 21240end 21241 21242@ @<Compile a ligature/kern...@>= 21243begin next_char(nl):=qi(c); skip_byte(nl):=qi(0); 21244if cur_mod<128 then {ligature op} 21245 begin op_byte(nl):=qi(cur_mod); rem_byte(nl):=qi(get_code); 21246 end 21247else begin get_x_next; scan_expression; 21248 if cur_type<>known then 21249 begin exp_err("Improper kern"); 21250@.Improper kern@> 21251 help2("The amount of kern should be a known numeric value.")@/ 21252 ("I'm zeroing this one. Proceed, with fingers crossed."); 21253 put_get_flush_error(0); 21254 end; 21255 kern[nk]:=cur_exp; 21256 k:=0;@+while kern[k]<>cur_exp do incr(k); 21257 if k=nk then 21258 begin if nk=max_kerns then overflow("kern",max_kerns); 21259@:METAFONT capacity exceeded kern}{\quad kern@> 21260 incr(nk); 21261 end; 21262 op_byte(nl):=kern_flag+(k div 256); 21263 rem_byte(nl):=qi((k mod 256)); 21264 end; 21265lk_started:=true; 21266end 21267 21268@ @d missing_extensible_punctuation(#)== 21269 begin missing_err(#); 21270@.Missing `\char`\#'@> 21271 help1("I'm processing `extensible c: t,m,b,r'."); back_error; 21272 end 21273 21274@<Define an extensible recipe@>= 21275begin if ne=256 then overflow("extensible",256); 21276@:METAFONT capacity exceeded extensible}{\quad extensible@> 21277c:=get_code; set_tag(c,ext_tag,ne); 21278if cur_cmd<>colon then missing_extensible_punctuation(":"); 21279ext_top(ne):=qi(get_code); 21280if cur_cmd<>comma then missing_extensible_punctuation(","); 21281ext_mid(ne):=qi(get_code); 21282if cur_cmd<>comma then missing_extensible_punctuation(","); 21283ext_bot(ne):=qi(get_code); 21284if cur_cmd<>comma then missing_extensible_punctuation(","); 21285ext_rep(ne):=qi(get_code); 21286incr(ne); 21287end 21288 21289@ @<Store a list of header bytes@>= 21290repeat if j>header_size then overflow("headerbyte",header_size); 21291@:METAFONT capacity exceeded headerbyte}{\quad headerbyte@> 21292header_byte[j]:=get_code; incr(j); 21293until cur_cmd<>comma 21294 21295@ @<Store a list of font dimensions@>= 21296repeat if j>max_font_dimen then overflow("fontdimen",max_font_dimen); 21297@:METAFONT capacity exceeded fontdimen}{\quad fontdimen@> 21298while j>np do 21299 begin incr(np); param[np]:=0; 21300 end; 21301get_x_next; scan_expression; 21302if cur_type<>known then 21303 begin exp_err("Improper font parameter"); 21304@.Improper font parameter@> 21305 help1("I'm zeroing this one. Proceed, with fingers crossed."); 21306 put_get_flush_error(0); 21307 end; 21308param[j]:=cur_exp; incr(j); 21309until cur_cmd<>comma 21310 21311@ OK: We've stored all the data that is needed for the \.{TFM} file. 21312All that remains is to output it in the correct format. 21313 21314An interesting problem needs to be solved in this connection, because 21315the \.{TFM} format allows at most 256~widths, 16~heights, 16~depths, 21316and 64~italic corrections. If the data has more distinct values than 21317this, we want to meet the necessary restrictions by perturbing the 21318given values as little as possible. 21319 21320\MF\ solves this problem in two steps. First the values of a given 21321kind (widths, heights, depths, or italic corrections) are sorted; 21322then the list of sorted values is perturbed, if necessary. 21323 21324The sorting operation is facilitated by having a special node of 21325essentially infinite |value| at the end of the current list. 21326 21327@<Initialize table entries...@>= 21328value(inf_val):=fraction_four; 21329 21330@ Straight linear insertion is good enough for sorting, since the lists 21331are usually not terribly long. As we work on the data, the current list 21332will start at |link(temp_head)| and end at |inf_val|; the nodes in this 21333list will be in increasing order of their |value| fields. 21334 21335Given such a list, the |sort_in| function takes a value and returns a pointer 21336to where that value can be found in the list. The value is inserted in 21337the proper place, if necessary. 21338 21339At the time we need to do these operations, most of \MF's work has been 21340completed, so we will have plenty of memory to play with. The value nodes 21341that are allocated for sorting will never be returned to free storage. 21342 21343@d clear_the_list==link(temp_head):=inf_val 21344 21345@p function sort_in(@!v:scaled):pointer; 21346label found; 21347var @!p,@!q,@!r:pointer; {list manipulation registers} 21348begin p:=temp_head; 21349loop@+ begin q:=link(p); 21350 if v<=value(q) then goto found; 21351 p:=q; 21352 end; 21353found: if v<value(q) then 21354 begin r:=get_node(value_node_size); value(r):=v; link(r):=q; link(p):=r; 21355 end; 21356sort_in:=link(p); 21357end; 21358 21359@ Now we come to the interesting part, where we reduce the list if necessary 21360until it has the required size. The |min_cover| routine is basic to this 21361process; it computes the minimum number~|m| such that the values of the 21362current sorted list can be covered by |m|~intervals of width~|d|. It 21363also sets the global value |perturbation| to the smallest value $d'>d$ 21364such that the covering found by this algorithm would be different. 21365 21366In particular, |min_cover(0)| returns the number of distinct values in the 21367current list and sets |perturbation| to the minimum distance between 21368adjacent values. 21369 21370@p function min_cover(@!d:scaled):integer; 21371var @!p:pointer; {runs through the current list} 21372@!l:scaled; {the least element covered by the current interval} 21373@!m:integer; {lower bound on the size of the minimum cover} 21374begin m:=0; p:=link(temp_head); perturbation:=el_gordo; 21375while p<>inf_val do 21376 begin incr(m); l:=value(p); 21377 repeat p:=link(p); 21378 until value(p)>l+d; 21379 if value(p)-l<perturbation then perturbation:=value(p)-l; 21380 end; 21381min_cover:=m; 21382end; 21383 21384@ @<Glob...@>= 21385@!perturbation:scaled; {quantity related to \.{TFM} rounding} 21386@!excess:integer; {the list is this much too long} 21387 21388@ The smallest |d| such that a given list can be covered with |m| intervals 21389is determined by the |threshold| routine, which is sort of an inverse 21390to |min_cover|. The idea is to increase the interval size rapidly until 21391finding the range, then to go sequentially until the exact borderline has 21392been discovered. 21393 21394@p function threshold(@!m:integer):scaled; 21395var @!d:scaled; {lower bound on the smallest interval size} 21396begin excess:=min_cover(0)-m; 21397if excess<=0 then threshold:=0 21398else begin repeat d:=perturbation; 21399 until min_cover(d+d)<=m; 21400 while min_cover(d)>m do d:=perturbation; 21401 threshold:=d; 21402 end; 21403end; 21404 21405@ The |skimp| procedure reduces the current list to at most |m| entries, 21406by changing values if necessary. It also sets |info(p):=k| if |value(p)| 21407is the |k|th distinct value on the resulting list, and it sets 21408|perturbation| to the maximum amount by which a |value| field has 21409been changed. The size of the resulting list is returned as the 21410value of |skimp|. 21411 21412@p function skimp(@!m:integer):integer; 21413var @!d:scaled; {the size of intervals being coalesced} 21414@!p,@!q,@!r:pointer; {list manipulation registers} 21415@!l:scaled; {the least value in the current interval} 21416@!v:scaled; {a compromise value} 21417begin d:=threshold(m); perturbation:=0; 21418q:=temp_head; m:=0; p:=link(temp_head); 21419while p<>inf_val do 21420 begin incr(m); l:=value(p); info(p):=m; 21421 if value(link(p))<=l+d then 21422 @<Replace an interval of values by its midpoint@>; 21423 q:=p; p:=link(p); 21424 end; 21425skimp:=m; 21426end; 21427 21428@ @<Replace an interval...@>= 21429begin repeat p:=link(p); info(p):=m; 21430decr(excess);@+if excess=0 then d:=0; 21431until value(link(p))>l+d; 21432v:=l+half(value(p)-l); 21433if value(p)-v>perturbation then perturbation:=value(p)-v; 21434r:=q; 21435repeat r:=link(r); value(r):=v; 21436until r=p; 21437link(q):=p; {remove duplicate values from the current list} 21438end 21439 21440@ A warning message is issued whenever something is perturbed by 21441more than 1/16\thinspace pt. 21442 21443@p procedure tfm_warning(@!m:small_number); 21444begin print_nl("(some "); print(int_name[m]); 21445@.some charwds...@> 21446@.some chardps...@> 21447@.some charhts...@> 21448@.some charics...@> 21449print(" values had to be adjusted by as much as "); 21450print_scaled(perturbation); print("pt)"); 21451end; 21452 21453@ Here's an example of how we use these routines. 21454The width data needs to be perturbed only if there are 256 distinct 21455widths, but \MF\ must check for this case even though it is 21456highly unusual. 21457 21458An integer variable |k| will be defined when we use this code. 21459The |dimen_head| array will contain pointers to the sorted 21460lists of dimensions. 21461 21462@<Massage the \.{TFM} widths@>= 21463clear_the_list; 21464for k:=bc to ec do if char_exists[k] then 21465 tfm_width[k]:=sort_in(tfm_width[k]); 21466nw:=skimp(255)+1; dimen_head[1]:=link(temp_head); 21467if perturbation>=@'10000 then tfm_warning(char_wd) 21468 21469@ @<Glob...@>= 21470@!dimen_head:array[1..4] of pointer; {lists of \.{TFM} dimensions} 21471 21472@ Heights, depths, and italic corrections are different from widths 21473not only because their list length is more severely restricted, but 21474also because zero values do not need to be put into the lists. 21475 21476@<Massage the \.{TFM} heights, depths, and italic corrections@>= 21477clear_the_list; 21478for k:=bc to ec do if char_exists[k] then 21479 if tfm_height[k]=0 then tfm_height[k]:=zero_val 21480 else tfm_height[k]:=sort_in(tfm_height[k]); 21481nh:=skimp(15)+1; dimen_head[2]:=link(temp_head); 21482if perturbation>=@'10000 then tfm_warning(char_ht); 21483clear_the_list; 21484for k:=bc to ec do if char_exists[k] then 21485 if tfm_depth[k]=0 then tfm_depth[k]:=zero_val 21486 else tfm_depth[k]:=sort_in(tfm_depth[k]); 21487nd:=skimp(15)+1; dimen_head[3]:=link(temp_head); 21488if perturbation>=@'10000 then tfm_warning(char_dp); 21489clear_the_list; 21490for k:=bc to ec do if char_exists[k] then 21491 if tfm_ital_corr[k]=0 then tfm_ital_corr[k]:=zero_val 21492 else tfm_ital_corr[k]:=sort_in(tfm_ital_corr[k]); 21493ni:=skimp(63)+1; dimen_head[4]:=link(temp_head); 21494if perturbation>=@'10000 then tfm_warning(char_ic) 21495 21496@ @<Initialize table entries...@>= 21497value(zero_val):=0; info(zero_val):=0; 21498 21499@ Bytes 5--8 of the header are set to the design size, unless the user has 21500some crazy reason for specifying them differently. 21501@^design size@> 21502 21503Error messages are not allowed at the time this procedure is called, 21504so a warning is printed instead. 21505 21506The value of |max_tfm_dimen| is calculated so that 21507$$\hbox{|make_scaled(16*max_tfm_dimen,internal[design_size])|} 21508 < \\{three\_bytes}.$$ 21509 21510@d three_bytes==@'100000000 {$2^{24}$} 21511 21512@p procedure fix_design_size; 21513var @!d:scaled; {the design size} 21514begin d:=internal[design_size]; 21515if (d<unity)or(d>=fraction_half) then 21516 begin if d<>0 then 21517 print_nl("(illegal design size has been changed to 128pt)"); 21518@.illegal design size...@> 21519 d:=@'40000000; internal[design_size]:=d; 21520 end; 21521if header_byte[5]<0 then if header_byte[6]<0 then 21522 if header_byte[7]<0 then if header_byte[8]<0 then 21523 begin header_byte[5]:=d div @'4000000; 21524 header_byte[6]:=(d div 4096) mod 256; 21525 header_byte[7]:=(d div 16) mod 256; 21526 header_byte[8]:=(d mod 16)*16; 21527 end; 21528max_tfm_dimen:=16*internal[design_size]-1-internal[design_size] div @'10000000; 21529if max_tfm_dimen>=fraction_half then max_tfm_dimen:=fraction_half-1; 21530end; 21531 21532@ The |dimen_out| procedure computes a |fix_word| relative to the 21533design size. If the data was out of range, it is corrected and the 21534global variable |tfm_changed| is increased by~one. 21535 21536@p function dimen_out(@!x:scaled):integer; 21537begin if abs(x)>max_tfm_dimen then 21538 begin incr(tfm_changed); 21539 if x>0 then x:=max_tfm_dimen@+else x:=-max_tfm_dimen; 21540 end; 21541x:=make_scaled(x*16,internal[design_size]); 21542dimen_out:=x; 21543end; 21544 21545@ @<Glob...@>= 21546@!max_tfm_dimen:scaled; {bound on widths, heights, kerns, etc.} 21547@!tfm_changed:integer; {the number of data entries that were out of bounds} 21548 21549@ If the user has not specified any of the first four header bytes, 21550the |fix_check_sum| procedure replaces them by a ``check sum'' computed 21551from the |tfm_width| data relative to the design size. 21552@^check sum@> 21553 21554@p procedure fix_check_sum; 21555label exit; 21556var @!k:eight_bits; {runs through character codes} 21557@!b1,@!b2,@!b3,@!b4:eight_bits; {bytes of the check sum} 21558@!x:integer; {hash value used in check sum computation} 21559begin if header_byte[1]<0 then if header_byte[2]<0 then 21560 if header_byte[3]<0 then if header_byte[4]<0 then 21561 begin @<Compute a check sum in |(b1,b2,b3,b4)|@>; 21562 header_byte[1]:=b1; header_byte[2]:=b2; 21563 header_byte[3]:=b3; header_byte[4]:=b4; return; 21564 end; 21565for k:=1 to 4 do if header_byte[k]<0 then header_byte[k]:=0; 21566exit:end; 21567 21568@ @<Compute a check sum in |(b1,b2,b3,b4)|@>= 21569b1:=bc; b2:=ec; b3:=bc; b4:=ec; tfm_changed:=0; 21570for k:=bc to ec do if char_exists[k] then 21571 begin x:=dimen_out(value(tfm_width[k]))+(k+4)*@'20000000; {this is positive} 21572 b1:=(b1+b1+x) mod 255; 21573 b2:=(b2+b2+x) mod 253; 21574 b3:=(b3+b3+x) mod 251; 21575 b4:=(b4+b4+x) mod 247; 21576 end 21577 21578@ Finally we're ready to actually write the \.{TFM} information. 21579Here are some utility routines for this purpose. 21580 21581@d tfm_out(#)==write(tfm_file,#) {output one byte to |tfm_file|} 21582 21583@p procedure tfm_two(@!x:integer); {output two bytes to |tfm_file|} 21584begin tfm_out(x div 256); tfm_out(x mod 256); 21585end; 21586@# 21587procedure tfm_four(@!x:integer); {output four bytes to |tfm_file|} 21588begin if x>=0 then tfm_out(x div three_bytes) 21589else begin x:=x+@'10000000000; {use two's complement for negative values} 21590 x:=x+@'10000000000; 21591 tfm_out((x div three_bytes) + 128); 21592 end; 21593x:=x mod three_bytes; tfm_out(x div unity); 21594x:=x mod unity; tfm_out(x div @'400); 21595tfm_out(x mod @'400); 21596end; 21597@# 21598procedure tfm_qqqq(@!x:four_quarters); {output four quarterwords to |tfm_file|} 21599begin tfm_out(qo(x.b0)); tfm_out(qo(x.b1)); tfm_out(qo(x.b2)); 21600tfm_out(qo(x.b3)); 21601end; 21602 21603@ @<Finish the \.{TFM} file@>= 21604if job_name=0 then open_log_file; 21605pack_job_name(".tfm"); 21606while not b_open_out(tfm_file) do 21607 prompt_file_name("file name for font metrics",".tfm"); 21608metric_file_name:=b_make_name_string(tfm_file); 21609@<Output the subfile sizes and header bytes@>; 21610@<Output the character information bytes, then 21611 output the dimensions themselves@>; 21612@<Output the ligature/kern program@>; 21613@<Output the extensible character recipes and the font metric parameters@>; 21614@!stat if internal[tracing_stats]>0 then 21615 @<Log the subfile sizes of the \.{TFM} file@>;@;@+tats@/ 21616print_nl("Font metrics written on "); slow_print(metric_file_name); 21617print_char("."); 21618@.Font metrics written...@> 21619b_close(tfm_file) 21620 21621@ Integer variables |lh|, |k|, and |lk_offset| will be defined when we use 21622this code. 21623 21624@<Output the subfile sizes and header bytes@>= 21625k:=header_size; 21626while header_byte[k]<0 do decr(k); 21627lh:=(k+3) div 4; {this is the number of header words} 21628if bc>ec then bc:=1; {if there are no characters, |ec=0| and |bc=1|} 21629@<Compute the ligature/kern program offset and implant the 21630 left boundary label@>; 21631tfm_two(6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+lk_offset+nk+ne+np); 21632 {this is the total number of file words that will be output} 21633tfm_two(lh); tfm_two(bc); tfm_two(ec); tfm_two(nw); tfm_two(nh); 21634tfm_two(nd); tfm_two(ni); tfm_two(nl+lk_offset); tfm_two(nk); tfm_two(ne); 21635tfm_two(np); 21636for k:=1 to 4*lh do 21637 begin if header_byte[k]<0 then header_byte[k]:=0; 21638 tfm_out(header_byte[k]); 21639 end 21640 21641@ @<Output the character information bytes...@>= 21642for k:=bc to ec do 21643 if not char_exists[k] then tfm_four(0) 21644 else begin tfm_out(info(tfm_width[k])); {the width index} 21645 tfm_out((info(tfm_height[k]))*16+info(tfm_depth[k])); 21646 tfm_out((info(tfm_ital_corr[k]))*4+char_tag[k]); 21647 tfm_out(char_remainder[k]); 21648 end; 21649tfm_changed:=0; 21650for k:=1 to 4 do 21651 begin tfm_four(0); p:=dimen_head[k]; 21652 while p<>inf_val do 21653 begin tfm_four(dimen_out(value(p))); p:=link(p); 21654 end; 21655 end 21656 21657@ We need to output special instructions at the beginning of the 21658|lig_kern| array in order to specify the right boundary character 21659and/or to handle starting addresses that exceed 255. The |label_loc| 21660and |label_char| arrays have been set up to record all the 21661starting addresses; we have $-1=|label_loc|[0]<|label_loc|[1]\le\cdots 21662\le|label_loc|[|label_ptr]|$. 21663 21664@<Compute the ligature/kern program offset...@>= 21665bchar:=round_unscaled(internal[boundary_char]); 21666if(bchar<0)or(bchar>255)then 21667 begin bchar:=-1; lk_started:=false; lk_offset:=0;@+end 21668else begin lk_started:=true; lk_offset:=1;@+end; 21669@<Find the minimum |lk_offset| and adjust all remainders@>; 21670if bch_label<undefined_label then 21671 begin skip_byte(nl):=qi(255); next_char(nl):=qi(0); 21672 op_byte(nl):=qi(((bch_label+lk_offset)div 256)); 21673 rem_byte(nl):=qi(((bch_label+lk_offset)mod 256)); 21674 incr(nl); {possibly |nl=lig_table_size+1|} 21675 end 21676 21677@ @<Find the minimum |lk_offset|...@>= 21678k:=label_ptr; {pointer to the largest unallocated label} 21679if label_loc[k]+lk_offset>255 then 21680 begin lk_offset:=0; lk_started:=false; {location 0 can do double duty} 21681 repeat char_remainder[label_char[k]]:=lk_offset; 21682 while label_loc[k-1]=label_loc[k] do 21683 begin decr(k); char_remainder[label_char[k]]:=lk_offset; 21684 end; 21685 incr(lk_offset); decr(k); 21686 until lk_offset+label_loc[k]<256; 21687 {N.B.: |lk_offset=256| satisfies this when |k=0|} 21688 end; 21689if lk_offset>0 then 21690 while k>0 do 21691 begin char_remainder[label_char[k]] 21692 :=char_remainder[label_char[k]]+lk_offset; 21693 decr(k); 21694 end 21695 21696@ @<Output the ligature/kern program@>= 21697for k:=0 to 255 do if skip_table[k]<undefined_label then 21698 begin print_nl("(local label "); print_int(k); print(":: was missing)"); 21699@.local label l:: was missing@> 21700 cancel_skips(skip_table[k]); 21701 end; 21702if lk_started then {|lk_offset=1| for the special |bchar|} 21703 begin tfm_out(255); tfm_out(bchar); tfm_two(0); 21704 end 21705else for k:=1 to lk_offset do {output the redirection specs} 21706 begin ll:=label_loc[label_ptr]; 21707 if bchar<0 then 21708 begin tfm_out(254); tfm_out(0); 21709 end 21710 else begin tfm_out(255); tfm_out(bchar); 21711 end; 21712 tfm_two(ll+lk_offset); 21713 repeat decr(label_ptr); 21714 until label_loc[label_ptr]<ll; 21715 end; 21716for k:=0 to nl-1 do tfm_qqqq(lig_kern[k]); 21717for k:=0 to nk-1 do tfm_four(dimen_out(kern[k])) 21718 21719@ @<Output the extensible character recipes...@>= 21720for k:=0 to ne-1 do tfm_qqqq(exten[k]); 21721for k:=1 to np do 21722 if k=1 then 21723 if abs(param[1])<fraction_half then tfm_four(param[1]*16) 21724 else begin incr(tfm_changed); 21725 if param[1]>0 then tfm_four(el_gordo) 21726 else tfm_four(-el_gordo); 21727 end 21728 else tfm_four(dimen_out(param[k])); 21729if tfm_changed>0 then 21730 begin if tfm_changed=1 then print_nl("(a font metric dimension") 21731@.a font metric dimension...@> 21732 else begin print_nl("("); print_int(tfm_changed); 21733@.font metric dimensions...@> 21734 print(" font metric dimensions"); 21735 end; 21736 print(" had to be decreased)"); 21737 end 21738 21739@ @<Log the subfile sizes of the \.{TFM} file@>= 21740begin wlog_ln(' '); 21741if bch_label<undefined_label then decr(nl); 21742wlog_ln('(You used ',nw:1,'w,',@| nh:1,'h,',@| nd:1,'d,',@| ni:1,'i,',@| 21743 nl:1,'l,',@| nk:1,'k,',@| ne:1,'e,',@| 21744 np:1,'p metric file positions'); 21745wlog_ln(' out of ',@| '256w,16h,16d,64i,',@| 21746 lig_table_size:1,'l,',max_kerns:1,'k,256e,',@| 21747 max_font_dimen:1,'p)'); 21748end 21749 21750@* \[46] Generic font file format. 21751The most important output produced by a typical run of \MF\ is the 21752``generic font'' (\.{GF}) file that specifies the bit patterns of the 21753characters that have been drawn. The term {\sl generic\/} indicates that 21754this file format doesn't match the conventions of any name-brand manufacturer; 21755but it is easy to convert \.{GF} files to the special format required by 21756almost all digital phototypesetting equipment. There's a strong analogy 21757between the \.{DVI} files written by \TeX\ and the \.{GF} files written 21758by \MF; and, in fact, the file formats have a lot in common. 21759 21760A \.{GF} file is a stream of 8-bit bytes that may be 21761regarded as a series of commands in a machine-like language. The first 21762byte of each command is the operation code, and this code is followed by 21763zero or more bytes that provide parameters to the command. The parameters 21764themselves may consist of several consecutive bytes; for example, the 21765`|boc|' (beginning of character) command has six parameters, each of 21766which is four bytes long. Parameters are usually regarded as nonnegative 21767integers; but four-byte-long parameters can be either positive or 21768negative, hence they range in value from $-2^{31}$ to $2^{31}-1$. 21769As in \.{TFM} files, numbers that occupy 21770more than one byte position appear in BigEndian order, 21771and negative numbers appear in two's complement notation. 21772 21773A \.{GF} file consists of a ``preamble,'' followed by a sequence of one or 21774more ``characters,'' followed by a ``postamble.'' The preamble is simply a 21775|pre| command, with its parameters that introduce the file; this must come 21776first. Each ``character'' consists of a |boc| command, followed by any 21777number of other commands that specify ``black'' pixels, 21778followed by an |eoc| command. The characters appear in the order that \MF\ 21779generated them. If we ignore no-op commands (which are allowed between any 21780two commands in the file), each |eoc| command is immediately followed by a 21781|boc| command, or by a |post| command; in the latter case, there are no 21782more characters in the file, and the remaining bytes form the postamble. 21783Further details about the postamble will be explained later. 21784 21785Some parameters in \.{GF} commands are ``pointers.'' These are four-byte 21786quantities that give the location number of some other byte in the file; 21787the first file byte is number~0, then comes number~1, and so on. 21788 21789@ The \.{GF} format is intended to be both compact and easily interpreted 21790by a machine. Compactness is achieved by making most of the information 21791relative instead of absolute. When a \.{GF}-reading program reads the 21792commands for a character, it keeps track of two quantities: (a)~the current 21793column number,~|m|; and (b)~the current row number,~|n|. These are 32-bit 21794signed integers, although most actual font formats produced from \.{GF} 21795files will need to curtail this vast range because of practical 21796limitations. (\MF\ output will never allow $\vert m\vert$ or $\vert 21797n\vert$ to get extremely large, but the \.{GF} format tries to be more general.) 21798 21799How do \.{GF}'s row and column numbers correspond to the conventions 21800of \TeX\ and \MF? Well, the ``reference point'' of a character, in \TeX's 21801view, is considered to be at the lower left corner of the pixel in row~0 21802and column~0. This point is the intersection of the baseline with the left 21803edge of the type; it corresponds to location $(0,0)$ in \MF\ programs. 21804Thus the pixel in \.{GF} row~0 and column~0 is \MF's unit square, comprising the 21805region of the plane whose coordinates both lie between 0 and~1. The 21806pixel in \.{GF} row~|n| and column~|m| consists of the points whose \MF\ 21807coordinates |(x,y)| satisfy |m<=x<=m+1| and |n<=y<=n+1|. Negative values of 21808|m| and~|x| correspond to columns of pixels {\sl left\/} of the reference 21809point; negative values of |n| and~|y| correspond to rows of pixels {\sl 21810below\/} the baseline. 21811 21812Besides |m| and |n|, there's also a third aspect of the current 21813state, namely the @!|paint_switch|, which is always either |black| or 21814|white|. Each \\{paint} command advances |m| by a specified amount~|d|, 21815and blackens the intervening pixels if |paint_switch=black|; then 21816the |paint_switch| changes to the opposite state. \.{GF}'s commands are 21817designed so that |m| will never decrease within a row, and |n| will never 21818increase within a character; hence there is no way to whiten a pixel that 21819has been blackened. 21820 21821@ Here is a list of all the commands that may appear in a \.{GF} file. Each 21822command is specified by its symbolic name (e.g., |boc|), its opcode byte 21823(e.g., 67), and its parameters (if any). The parameters are followed 21824by a bracketed number telling how many bytes they occupy; for example, 21825`|d[2]|' means that parameter |d| is two bytes long. 21826 21827\yskip\hang|paint_0| 0. This is a \\{paint} command with |d=0|; it does 21828nothing but change the |paint_switch| from \\{black} to \\{white} or vice~versa. 21829 21830\yskip\hang\\{paint\_1} through \\{paint\_63} (opcodes 1 to 63). 21831These are \\{paint} commands with |d=1| to~63, defined as follows: If 21832|paint_switch=black|, blacken |d|~pixels of the current row~|n|, 21833in columns |m| through |m+d-1| inclusive. Then, in any case, 21834complement the |paint_switch| and advance |m| by~|d|. 21835 21836\yskip\hang|paint1| 64 |d[1]|. This is a \\{paint} command with a specified 21837value of~|d|; \MF\ uses it to paint when |64<=d<256|. 21838 21839\yskip\hang|@!paint2| 65 |d[2]|. Same as |paint1|, but |d|~can be as high 21840as~65535. 21841 21842\yskip\hang|@!paint3| 66 |d[3]|. Same as |paint1|, but |d|~can be as high 21843as $2^{24}-1$. \MF\ never needs this command, and it is hard to imagine 21844anybody making practical use of it; surely a more compact encoding will be 21845desirable when characters can be this large. But the command is there, 21846anyway, just in case. 21847 21848\yskip\hang|boc| 67 |c[4]| |p[4]| |min_m[4]| |max_m[4]| |min_n[4]| 21849|max_n[4]|. Beginning of a character: Here |c| is the character code, and 21850|p| points to the previous character beginning (if any) for characters having 21851this code number modulo 256. (The pointer |p| is |-1| if there was no 21852prior character with an equivalent code.) The values of registers |m| and |n| 21853defined by the instructions that follow for this character must 21854satisfy |min_m<=m<=max_m| and |min_n<=n<=max_n|. (The values of |max_m| and 21855|min_n| need not be the tightest bounds possible.) When a \.{GF}-reading 21856program sees a |boc|, it can use |min_m|, |max_m|, |min_n|, and |max_n| to 21857initialize the bounds of an array. Then it sets |m:=min_m|, |n:=max_n|, and 21858|paint_switch:=white|. 21859 21860\yskip\hang|boc1| 68 |c[1]| |@!del_m[1]| |max_m[1]| |@!del_n[1]| |max_n[1]|. 21861Same as |boc|, but |p| is assumed to be~$-1$; also |del_m=max_m-min_m| 21862and |del_n=max_n-min_n| are given instead of |min_m| and |min_n|. 21863The one-byte parameters must be between 0 and 255, inclusive. 21864\ (This abbreviated |boc| saves 19~bytes per character, in common cases.) 21865 21866\yskip\hang|eoc| 69. End of character: All pixels blackened so far 21867constitute the pattern for this character. In particular, a completely 21868blank character might have |eoc| immediately following |boc|. 21869 21870\yskip\hang|skip0| 70. Decrease |n| by 1 and set |m:=min_m|, 21871|paint_switch:=white|. \ (This finishes one row and begins another, 21872ready to whiten the leftmost pixel in the new row.) 21873 21874\yskip\hang|skip1| 71 |d[1]|. Decrease |n| by |d+1|, set |m:=min_m|, and set 21875|paint_switch:=white|. This is a way to produce |d| all-white rows. 21876 21877\yskip\hang|@!skip2| 72 |d[2]|. Same as |skip1|, but |d| can be as large 21878as 65535. 21879 21880\yskip\hang|@!skip3| 73 |d[3]|. Same as |skip1|, but |d| can be as large 21881as $2^{24}-1$. \MF\ obviously never needs this command. 21882 21883\yskip\hang|new_row_0| 74. Decrease |n| by 1 and set |m:=min_m|, 21884|paint_switch:=black|. \ (This finishes one row and begins another, 21885ready to {\sl blacken\/} the leftmost pixel in the new row.) 21886 21887\yskip\hang|@!new_row_1| through |@!new_row_164| (opcodes 75 to 238). Same as 21888|new_row_0|, but with |m:=min_m+1| through |min_m+164|, respectively. 21889 21890\yskip\hang|xxx1| 239 |k[1]| |x[k]|. This command is undefined in 21891general; it functions as a $(k+2)$-byte |no_op| unless special \.{GF}-reading 21892programs are being used. \MF\ generates \\{xxx} commands when encountering 21893a \&{special} string; this occurs in the \.{GF} file only between 21894characters, after the preamble, and before the postamble. However, 21895\\{xxx} commands might appear within characters, 21896in \.{GF} files generated by other 21897processors. It is recommended that |x| be a string having the form of a 21898keyword followed by possible parameters relevant to that keyword. 21899 21900\yskip\hang|@!xxx2| 240 |k[2]| |x[k]|. Like |xxx1|, but |0<=k<65536|. 21901 21902\yskip\hang|xxx3| 241 |k[3]| |x[k]|. Like |xxx1|, but |0<=k<@t$2^{24}$@>|. 21903\MF\ uses this when sending a \&{special} string whose length exceeds~255. 21904 21905\yskip\hang|@!xxx4| 242 |k[4]| |x[k]|. Like |xxx1|, but |k| can be 21906ridiculously large; |k| mustn't be negative. 21907 21908\yskip\hang|yyy| 243 |y[4]|. This command is undefined in general; 21909it functions as a 5-byte |no_op| unless special \.{GF}-reading programs 21910are being used. \MF\ puts |scaled| numbers into |yyy|'s, as a 21911result of \&{numspecial} commands; the intent is to provide numeric 21912parameters to \\{xxx} commands that immediately precede. 21913 21914\yskip\hang|@!no_op| 244. No operation, do nothing. Any number of |no_op|'s 21915may occur between \.{GF} commands, but a |no_op| cannot be inserted between 21916a command and its parameters or between two parameters. 21917 21918\yskip\hang|char_loc| 245 |c[1]| |dx[4]| |dy[4]| |w[4]| |p[4]|. 21919This command will appear only in the postamble, which will be explained shortly. 21920 21921\yskip\hang|@!char_loc0| 246 |c[1]| |@!dm[1]| |w[4]| |p[4]|. 21922Same as |char_loc|, except that |dy| is assumed to be zero, and the value 21923of~|dx| is taken to be |65536*dm|, where |0<=dm<256|. 21924 21925\yskip\hang|pre| 247 |i[1]| |k[1]| |x[k]|. 21926Beginning of the preamble; this must come at the very beginning of the 21927file. Parameter |i| is an identifying number for \.{GF} format, currently 21928131. The other information is merely commentary; it is not given 21929special interpretation like \\{xxx} commands are. (Note that \\{xxx} 21930commands may immediately follow the preamble, before the first |boc|.) 21931 21932\yskip\hang|post| 248. Beginning of the postamble, see below. 21933 21934\yskip\hang|post_post| 249. Ending of the postamble, see below. 21935 21936\yskip\noindent Commands 250--255 are undefined at the present time. 21937 21938@d gf_id_byte=131 {identifies the kind of \.{GF} files described here} 21939 21940@ \MF\ refers to the following opcodes explicitly. 21941 21942@d paint_0=0 {beginning of the \\{paint} commands} 21943@d paint1=64 {move right a given number of columns, then 21944 black${}\swap{}$white} 21945@d boc=67 {beginning of a character} 21946@d boc1=68 {short form of |boc|} 21947@d eoc=69 {end of a character} 21948@d skip0=70 {skip no blank rows} 21949@d skip1=71 {skip over blank rows} 21950@d new_row_0=74 {move down one row and then right} 21951@d max_new_row=164 {the largest \\{new\_row} command is |new_row_164|} 21952@d xxx1=239 {for \&{special} strings} 21953@d xxx3=241 {for long \&{special} strings} 21954@d yyy=243 {for \&{numspecial} numbers} 21955@d char_loc=245 {character locators in the postamble} 21956@d pre=247 {preamble} 21957@d post=248 {postamble beginning} 21958@d post_post=249 {postamble ending} 21959 21960@ The last character in a \.{GF} file is followed by `|post|'; this command 21961introduces the postamble, which summarizes important facts that \MF\ has 21962accumulated. The postamble has the form 21963$$\vbox{\halign{\hbox{#\hfil}\cr 21964 |post| |p[4]| |@!ds[4]| |@!cs[4]| |@!hppp[4]| |@!vppp[4]| 21965 |@!min_m[4]| |@!max_m[4]| |@!min_n[4]| |@!max_n[4]|\cr 21966 $\langle\,$character locators$\,\rangle$\cr 21967 |post_post| |q[4]| |i[1]| 223's$[{\G}4]$\cr}}$$ 21968Here |p| is a pointer to the byte following the final |eoc| in the file 21969(or to the byte following the preamble, if there are no characters); 21970it can be used to locate the beginning of \\{xxx} commands 21971that might have preceded the postamble. The |ds| and |cs| parameters 21972@^design size@> @^check sum@> 21973give the design size and check sum, respectively, which are exactly the 21974values put into the header of the \.{TFM} file that \MF\ produces (or 21975would produce) on this run. Parameters |hppp| and |vppp| are the ratios of 21976pixels per point, horizontally and vertically, expressed as |scaled| integers 21977(i.e., multiplied by $2^{16}$); they can be used to correlate the font 21978with specific device resolutions, magnifications, and ``at sizes.'' Then 21979come |min_m|, |max_m|, |min_n|, and |max_n|, which bound the values that 21980registers |m| and~|n| assume in all characters in this \.{GF} file. 21981(These bounds need not be the best possible; |max_m| and |min_n| may, on the 21982other hand, be tighter than the similar bounds in |boc| commands. For 21983example, some character may have |min_n=-100| in its |boc|, but it might 21984turn out that |n| never gets lower than |-50| in any character; then 21985|min_n| can have any value |<=-50|. If there are no characters in the file, 21986it's possible to have |min_m>max_m| and/or |min_n>max_n|.) 21987 21988@ Character locators are introduced by |char_loc| commands, 21989which specify a character residue~|c|, character escapements (|dx,dy|), 21990a character width~|w|, and a pointer~|p| 21991to the beginning of that character. (If two or more characters have the 21992same code~|c| modulo 256, only the last will be indicated; the others can be 21993located by following backpointers. Characters whose codes differ by a 21994multiple of 256 are assumed to share the same font metric information, 21995hence the \.{TFM} file contains only residues of character codes modulo~256. 21996This convention is intended for oriental languages, when there are many 21997character shapes but few distinct widths.) 21998@^oriental characters@>@^Chinese characters@>@^Japanese characters@> 21999 22000The character escapements (|dx,dy|) are the values of \MF's \&{chardx} 22001and \&{chardy} parameters; they are in units of |scaled| pixels; 22002i.e., |dx| is in horizontal pixel units times $2^{16}$, and |dy| is in 22003vertical pixel units times $2^{16}$. This is the intended amount of 22004displacement after typesetting the character; for \.{DVI} files, |dy| 22005should be zero, but other document file formats allow nonzero vertical 22006escapement. 22007 22008The character width~|w| duplicates the information in the \.{TFM} file; it 22009is a |fix_word| value relative to the design size, and it should be 22010independent of magnification. 22011 22012The backpointer |p| points to the character's |boc|, or to the first of 22013a sequence of consecutive \\{xxx} or |yyy| or |no_op| commands that 22014immediately precede the |boc|, if such commands exist; such ``special'' 22015commands essentially belong to the characters, while the special commands 22016after the final character belong to the postamble (i.e., to the font 22017as a whole). This convention about |p| applies also to the backpointers 22018in |boc| commands, even though it wasn't explained in the description 22019of~|boc|. @^backpointers@> 22020 22021Pointer |p| might be |-1| if the character exists in the \.{TFM} file 22022but not in the \.{GF} file. This unusual situation can arise in \MF\ output 22023if the user had |proofing<0| when the character was being shipped out, 22024but then made |proofing>=0| in order to get a \.{GF} file. 22025 22026@ The last part of the postamble, following the |post_post| byte that 22027signifies the end of the character locators, contains |q|, a pointer to the 22028|post| command that started the postamble. An identification byte, |i|, 22029comes next; this currently equals~131, as in the preamble. 22030 22031The |i| byte is followed by four or more bytes that are all equal to 22032the decimal number 223 (i.e., @'337 in octal). \MF\ puts out four to seven of 22033these trailing bytes, until the total length of the file is a multiple of 22034four bytes, since this works out best on machines that pack four bytes per 22035word; but any number of 223's is allowed, as long as there are at least four 22036of them. In effect, 223 is a sort of signature that is added at the very end. 22037@^Fuchs, David Raymond@> 22038 22039This curious way to finish off a \.{GF} file makes it feasible for 22040\.{GF}-reading programs to find the postamble first, on most computers, 22041even though \MF\ wants to write the postamble last. Most operating 22042systems permit random access to individual words or bytes of a file, so 22043the \.{GF} reader can start at the end and skip backwards over the 223's 22044until finding the identification byte. Then it can back up four bytes, read 22045|q|, and move to byte |q| of the file. This byte should, of course, 22046contain the value 248 (|post|); now the postamble can be read, so the 22047\.{GF} reader can discover all the information needed for individual characters. 22048 22049Unfortunately, however, standard \PASCAL\ does not include the ability to 22050@^system dependencies@> 22051access a random position in a file, or even to determine the length of a file. 22052Almost all systems nowadays provide the necessary capabilities, so \.{GF} 22053format has been designed to work most efficiently with modern operating systems. 22054But if \.{GF} files have to be processed under the restrictions of standard 22055\PASCAL, one can simply read them from front to back. This will 22056be adequate for most applications. However, the postamble-first approach 22057would facilitate a program that merges two \.{GF} files, replacing data 22058from one that is overridden by corresponding data in the other. 22059 22060@* \[47] Shipping characters out. 22061The |ship_out| procedure, to be described below, is given a pointer to 22062an edge structure. Its mission is to describe the positive pixels 22063in \.{GF} form, outputting a ``character'' to |gf_file|. 22064 22065Several global variables hold information about the font file as a whole:\ 22066|gf_min_m|, |gf_max_m|, |gf_min_n|, and |gf_max_n| are the minimum and 22067maximum \.{GF} coordinates output so far; |gf_prev_ptr| is the byte number 22068following the preamble or the last |eoc| command in the output; 22069|total_chars| is the total number of characters (i.e., |boc..eoc| segments) 22070shipped out. There's also an array, |char_ptr|, containing the starting 22071positions of each character in the file, as required for the postamble. If 22072character code~|c| has not yet been output, |char_ptr[c]=-1|. 22073 22074@<Glob...@>= 22075@!gf_min_m,@!gf_max_m,@!gf_min_n,@!gf_max_n:integer; {bounding rectangle} 22076@!gf_prev_ptr:integer; {where the present/next character started/starts} 22077@!total_chars:integer; {the number of characters output so far} 22078@!char_ptr:array[eight_bits] of integer; {where individual characters started} 22079@!gf_dx,@!gf_dy:array[eight_bits] of integer; {device escapements} 22080 22081@ @<Set init...@>= 22082gf_prev_ptr:=0; total_chars:=0; 22083 22084@ The \.{GF} bytes are output to a buffer instead of being sent 22085byte-by-byte to |gf_file|, because this tends to save a lot of 22086subroutine-call overhead. \MF\ uses the same conventions for |gf_file| 22087as \TeX\ uses for its \\{dvi\_file}; hence if system-dependent 22088changes are needed, they should probably be the same for both programs. 22089 22090The output buffer is divided into two parts of equal size; the bytes found 22091in |gf_buf[0..half_buf-1]| constitute the first half, and those in 22092|gf_buf[half_buf..gf_buf_size-1]| constitute the second. The global 22093variable |gf_ptr| points to the position that will receive the next 22094output byte. When |gf_ptr| reaches |gf_limit|, which is always equal 22095to one of the two values |half_buf| or |gf_buf_size|, the half buffer that 22096is about to be invaded next is sent to the output and |gf_limit| is 22097changed to its other value. Thus, there is always at least a half buffer's 22098worth of information present, except at the very beginning of the job. 22099 22100Bytes of the \.{GF} file are numbered sequentially starting with 0; 22101the next byte to be generated will be number |gf_offset+gf_ptr|. 22102 22103@<Types...@>= 22104@!gf_index=0..gf_buf_size; {an index into the output buffer} 22105 22106@ Some systems may find it more efficient to make |gf_buf| a |packed| 22107array, since output of four bytes at once may be facilitated. 22108@^system dependencies@> 22109 22110@<Glob...@>= 22111@!gf_buf:array[gf_index] of eight_bits; {buffer for \.{GF} output} 22112@!half_buf:gf_index; {half of |gf_buf_size|} 22113@!gf_limit:gf_index; {end of the current half buffer} 22114@!gf_ptr:gf_index; {the next available buffer address} 22115@!gf_offset:integer; {|gf_buf_size| times the number of times the 22116 output buffer has been fully emptied} 22117 22118@ Initially the buffer is all in one piece; we will output half of it only 22119after it first fills up. 22120 22121@<Set init...@>= 22122half_buf:=gf_buf_size div 2; gf_limit:=gf_buf_size; gf_ptr:=0; 22123gf_offset:=0; 22124 22125@ The actual output of |gf_buf[a..b]| to |gf_file| is performed by calling 22126|write_gf(a,b)|. It is safe to assume that |a| and |b+1| will both be 22127multiples of 4 when |write_gf(a,b)| is called; therefore it is possible on 22128many machines to use efficient methods to pack four bytes per word and to 22129output an array of words with one system call. 22130@^system dependencies@> 22131 22132@<Declare generic font output procedures@>= 22133procedure write_gf(@!a,@!b:gf_index); 22134var k:gf_index; 22135begin for k:=a to b do write(gf_file,gf_buf[k]); 22136end; 22137 22138@ To put a byte in the buffer without paying the cost of invoking a procedure 22139each time, we use the macro |gf_out|. 22140 22141@d gf_out(#)==@+begin gf_buf[gf_ptr]:=#; incr(gf_ptr); 22142 if gf_ptr=gf_limit then gf_swap; 22143 end 22144 22145@<Declare generic font output procedures@>= 22146procedure gf_swap; {outputs half of the buffer} 22147begin if gf_limit=gf_buf_size then 22148 begin write_gf(0,half_buf-1); gf_limit:=half_buf; 22149 gf_offset:=gf_offset+gf_buf_size; gf_ptr:=0; 22150 end 22151else begin write_gf(half_buf,gf_buf_size-1); gf_limit:=gf_buf_size; 22152 end; 22153end; 22154 22155@ Here is how we clean out the buffer when \MF\ is all through; |gf_ptr| 22156will be a multiple of~4. 22157 22158@<Empty the last bytes out of |gf_buf|@>= 22159if gf_limit=half_buf then write_gf(half_buf,gf_buf_size-1); 22160if gf_ptr>0 then write_gf(0,gf_ptr-1) 22161 22162@ The |gf_four| procedure outputs four bytes in two's complement notation, 22163without risking arithmetic overflow. 22164 22165@<Declare generic font output procedures@>= 22166procedure gf_four(@!x:integer); 22167begin if x>=0 then gf_out(x div three_bytes) 22168else begin x:=x+@'10000000000; 22169 x:=x+@'10000000000; 22170 gf_out((x div three_bytes) + 128); 22171 end; 22172x:=x mod three_bytes; gf_out(x div unity); 22173x:=x mod unity; gf_out(x div @'400); 22174gf_out(x mod @'400); 22175end; 22176 22177@ Of course, it's even easier to output just two or three bytes. 22178 22179@<Declare generic font output procedures@>= 22180procedure gf_two(@!x:integer); 22181begin gf_out(x div @'400); gf_out(x mod @'400); 22182end; 22183@# 22184procedure gf_three(@!x:integer); 22185begin gf_out(x div unity); gf_out((x mod unity) div @'400); 22186gf_out(x mod @'400); 22187end; 22188 22189@ We need a simple routine to generate a \\{paint} 22190command of the appropriate type. 22191 22192@<Declare generic font output procedures@>= 22193procedure gf_paint(@!d:integer); {here |0<=d<65536|} 22194begin if d<64 then gf_out(paint_0+d) 22195else if d<256 then 22196 begin gf_out(paint1); gf_out(d); 22197 end 22198else begin gf_out(paint1+1); gf_two(d); 22199 end; 22200end; 22201 22202@ And |gf_string| outputs one or two strings. If the first string number 22203is nonzero, an \\{xxx} command is generated. 22204 22205@<Declare generic font output procedures@>= 22206procedure gf_string(@!s,@!t:str_number); 22207var @!k:pool_pointer; 22208@!l:integer; {length of the strings to output} 22209begin if s<>0 then 22210 begin l:=length(s); 22211 if t<>0 then l:=l+length(t); 22212 if l<=255 then 22213 begin gf_out(xxx1); gf_out(l); 22214 end 22215 else begin gf_out(xxx3); gf_three(l); 22216 end; 22217 for k:=str_start[s] to str_start[s+1]-1 do gf_out(so(str_pool[k])); 22218 end; 22219if t<>0 then for k:=str_start[t] to str_start[t+1]-1 do gf_out(so(str_pool[k])); 22220end; 22221 22222@ The choice between |boc| commands is handled by |gf_boc|. 22223 22224@d one_byte(#)== #>=0 then if #<256 22225 22226@<Declare generic font output procedures@>= 22227procedure gf_boc(@!min_m,@!max_m,@!min_n,@!max_n:integer); 22228label exit; 22229begin if min_m<gf_min_m then gf_min_m:=min_m; 22230if max_n>gf_max_n then gf_max_n:=max_n; 22231if boc_p=-1 then if one_byte(boc_c) then 22232 if one_byte(max_m-min_m) then if one_byte(max_m) then 22233 if one_byte(max_n-min_n) then if one_byte(max_n) then 22234 begin gf_out(boc1); gf_out(boc_c);@/ 22235 gf_out(max_m-min_m); gf_out(max_m); 22236 gf_out(max_n-min_n); gf_out(max_n); return; 22237 end; 22238gf_out(boc); gf_four(boc_c); gf_four(boc_p);@/ 22239gf_four(min_m); gf_four(max_m); gf_four(min_n); gf_four(max_n); 22240exit: end; 22241 22242@ Two of the parameters to |gf_boc| are global. 22243 22244@<Glob...@>= 22245@!boc_c,@!boc_p:integer; {parameters of the next |boc| command} 22246 22247@ Here is a routine that gets a \.{GF} file off to a good start. 22248 22249@d check_gf==@t@>@+if output_file_name=0 then init_gf 22250 22251@<Declare generic font output procedures@>= 22252procedure init_gf; 22253var @!k:eight_bits; {runs through all possible character codes} 22254@!t:integer; {the time of this run} 22255begin gf_min_m:=4096; gf_max_m:=-4096; gf_min_n:=4096; gf_max_n:=-4096; 22256for k:=0 to 255 do char_ptr[k]:=-1; 22257@<Determine the file extension, |gf_ext|@>; 22258set_output_file_name; 22259gf_out(pre); gf_out(gf_id_byte); {begin to output the preamble} 22260old_setting:=selector; selector:=new_string; print(" METAFONT output "); 22261print_int(round_unscaled(internal[year])); print_char("."); 22262print_dd(round_unscaled(internal[month])); print_char("."); 22263print_dd(round_unscaled(internal[day])); print_char(":");@/ 22264t:=round_unscaled(internal[time]); 22265print_dd(t div 60); print_dd(t mod 60);@/ 22266selector:=old_setting; gf_out(cur_length); 22267gf_string(0,make_string); decr(str_ptr); 22268pool_ptr:=str_start[str_ptr]; {flush that string from memory} 22269gf_prev_ptr:=gf_offset+gf_ptr; 22270end; 22271 22272@ @<Determine the file extension...@>= 22273if internal[hppp]<=0 then gf_ext:=".gf" 22274else begin old_setting:=selector; selector:=new_string; print_char("."); 22275 print_int(make_scaled(internal[hppp],59429463)); 22276 {$2^{32}/72.27\approx59429463.07$} 22277 print("gf"); gf_ext:=make_string; selector:=old_setting; 22278 end 22279 22280@ With those preliminaries out of the way, |ship_out| is not especially 22281difficult. 22282 22283@<Declare generic font output procedures@>= 22284procedure ship_out(@!c:eight_bits); 22285label done; 22286var @!f:integer; {current character extension} 22287@!prev_m,@!m,@!mm:integer; {previous and current pixel column numbers} 22288@!prev_n,@!n:integer; {previous and current pixel row numbers} 22289@!p,@!q:pointer; {for list traversal} 22290@!prev_w,@!w,@!ww:integer; {old and new weights} 22291@!d:integer; {data from edge-weight node} 22292@!delta:integer; {number of rows to skip} 22293@!cur_min_m:integer; {starting column, relative to the current offset} 22294@!x_off,@!y_off:integer; {offsets, rounded to integers} 22295begin check_gf; f:=round_unscaled(internal[char_ext]);@/ 22296x_off:=round_unscaled(internal[x_offset]); 22297y_off:=round_unscaled(internal[y_offset]); 22298if term_offset>max_print_line-9 then print_ln 22299else if (term_offset>0)or(file_offset>0) then print_char(" "); 22300print_char("["); print_int(c); 22301if f<>0 then 22302 begin print_char("."); print_int(f); 22303 end; 22304update_terminal; 22305boc_c:=256*f+c; boc_p:=char_ptr[c]; char_ptr[c]:=gf_prev_ptr;@/ 22306if internal[proofing]>0 then @<Send nonzero offsets to the output file@>; 22307@<Output the character represented in |cur_edges|@>; 22308gf_out(eoc); gf_prev_ptr:=gf_offset+gf_ptr; incr(total_chars); 22309print_char("]"); update_terminal; {progress report} 22310if internal[tracing_output]>0 then 22311 print_edges(" (just shipped out)",true,x_off,y_off); 22312end; 22313 22314@ @<Send nonzero offsets to the output file@>= 22315begin if x_off<>0 then 22316 begin gf_string("xoffset",0); gf_out(yyy); gf_four(x_off*unity); 22317 end; 22318if y_off<>0 then 22319 begin gf_string("yoffset",0); gf_out(yyy); gf_four(y_off*unity); 22320 end; 22321end 22322 22323@ @<Output the character represented in |cur_edges|@>= 22324prev_n:=4096; p:=knil(cur_edges); n:=n_max(cur_edges)-zero_field; 22325while p<>cur_edges do 22326 begin @<Output the pixels of edge row |p| to font row |n|@>; 22327 p:=knil(p); decr(n); 22328 end; 22329if prev_n=4096 then @<Finish off an entirely blank character@> 22330else if prev_n+y_off<gf_min_n then 22331 gf_min_n:=prev_n+y_off 22332 22333@ @<Finish off an entirely blank...@>= 22334begin gf_boc(0,0,0,0); 22335if gf_max_m<0 then gf_max_m:=0; 22336if gf_min_n>0 then gf_min_n:=0; 22337end 22338 22339@ In this loop, |prev_w| represents the weight at column |prev_m|, which is 22340the most recent column reflected in the output so far; |w| represents the 22341weight at column~|m|, which is the most recent column in the edge data. 22342Several edges might cancel at the same column position, so we need to 22343look ahead to column~|mm| before actually outputting anything. 22344 22345@<Output the pixels of edge row |p| to font row |n|@>= 22346if unsorted(p)>void then sort_edges(p); 22347q:=sorted(p); w:=0; prev_m:=-fraction_one; {$|fraction_one|\approx\infty$} 22348ww:=0; prev_w:=0; m:=prev_m; 22349repeat if q=sentinel then mm:=fraction_one 22350else begin d:=ho(info(q)); mm:=d div 8; ww:=ww+(d mod 8)-zero_w; 22351 end; 22352if mm<>m then 22353 begin if prev_w<=0 then 22354 begin if w>0 then @<Start black at $(m,n)$@>; 22355 end 22356 else if w<=0 then @<Stop black at $(m,n)$@>; 22357 m:=mm; 22358 end; 22359w:=ww; q:=link(q); 22360until mm=fraction_one; 22361if w<>0 then {this should be impossible} 22362 print_nl("(There's unbounded black in character shipped out!)"); 22363@.There's unbounded black...@> 22364if prev_m-m_offset(cur_edges)+x_off>gf_max_m then 22365 gf_max_m:=prev_m-m_offset(cur_edges)+x_off 22366 22367 22368@ @<Start black at $(m,n)$@>= 22369begin if prev_m=-fraction_one then @<Start a new row at $(m,n)$@> 22370else gf_paint(m-prev_m); 22371prev_m:=m; prev_w:=w; 22372end 22373 22374@ @<Stop black at $(m,n)$@>= 22375begin gf_paint(m-prev_m); prev_m:=m; prev_w:=w; 22376end 22377 22378@ @<Start a new row at $(m,n)$@>= 22379begin if prev_n=4096 then 22380 begin gf_boc(m_min(cur_edges)+x_off-zero_field, 22381 m_max(cur_edges)+x_off-zero_field,@| 22382 n_min(cur_edges)+y_off-zero_field,n+y_off); 22383 cur_min_m:=m_min(cur_edges)-zero_field+m_offset(cur_edges); 22384 end 22385else if prev_n>n+1 then @<Skip down |prev_n-n| rows@> 22386else @<Skip to column $m$ in the next row and |goto done|, or skip zero rows@>; 22387gf_paint(m-cur_min_m); {skip to column $m$, painting white} 22388done:prev_n:=n; 22389end 22390 22391@ @<Skip to column $m$ in the next row...@>= 22392begin delta:=m-cur_min_m; 22393if delta>max_new_row then gf_out(skip0) 22394else begin gf_out(new_row_0+delta); goto done; 22395 end; 22396end 22397 22398@ @<Skip down...@>= 22399begin delta:=prev_n-n-1; 22400if delta<@'400 then 22401 begin gf_out(skip1); gf_out(delta); 22402 end 22403else begin gf_out(skip1+1); gf_two(delta); 22404 end; 22405end 22406 22407@ Now that we've finished |ship_out|, let's look at the other commands 22408by which a user can send things to the \.{GF} file. 22409 22410@<Cases of |do_statement|...@>= 22411special_command: do_special; 22412 22413@ @<Put each...@>= 22414primitive("special",special_command,string_type);@/ 22415@!@:special_}{\&{special} primitive@> 22416primitive("numspecial",special_command,known);@/ 22417@!@:num_special_}{\&{numspecial} primitive@> 22418 22419@ @<Declare action procedures for use by |do_statement|@>= 22420procedure do_special; 22421var @!m:small_number; {either |string_type| or |known|} 22422begin m:=cur_mod; get_x_next; scan_expression; 22423if internal[proofing]>=0 then 22424 if cur_type<>m then @<Complain about improper special operation@> 22425 else begin check_gf; 22426 if m=string_type then gf_string(cur_exp,0) 22427 else begin gf_out(yyy); gf_four(cur_exp); 22428 end; 22429 end; 22430flush_cur_exp(0); 22431end; 22432 22433@ @<Complain about improper special operation@>= 22434begin exp_err("Unsuitable expression"); 22435@.Unsuitable expression@> 22436help1("The expression shown above has the wrong type to be output."); 22437put_get_error; 22438end 22439 22440@ @<Send the current expression as a title to the output file@>= 22441begin check_gf; gf_string("title ",cur_exp); 22442@.title@> 22443end 22444 22445@ @<Cases of |print_cmd...@>= 22446special_command:if m=known then print("numspecial") 22447 else print("special"); 22448 22449@ @<Determine if a character has been shipped out@>= 22450begin cur_exp:=round_unscaled(cur_exp) mod 256; 22451if cur_exp<0 then cur_exp:=cur_exp+256; 22452boolean_reset(char_exists[cur_exp]); cur_type:=boolean_type; 22453end 22454 22455@ At the end of the program we must finish things off by writing the postamble. 22456The \.{TFM} information should have been computed first. 22457 22458An integer variable |k| and a |scaled| variable |x| will be declared for 22459use by this routine. 22460 22461@<Finish the \.{GF} file@>= 22462begin gf_out(post); {beginning of the postamble} 22463gf_four(gf_prev_ptr); gf_prev_ptr:=gf_offset+gf_ptr-5; {|post| location} 22464gf_four(internal[design_size]*16); 22465for k:=1 to 4 do gf_out(header_byte[k]); {the check sum} 22466gf_four(internal[hppp]); 22467gf_four(internal[vppp]);@/ 22468gf_four(gf_min_m); gf_four(gf_max_m); 22469gf_four(gf_min_n); gf_four(gf_max_n); 22470for k:=0 to 255 do if char_exists[k] then 22471 begin x:=gf_dx[k] div unity; 22472 if (gf_dy[k]=0)and(x>=0)and(x<256)and(gf_dx[k]=x*unity) then 22473 begin gf_out(char_loc+1); gf_out(k); gf_out(x); 22474 end 22475 else begin gf_out(char_loc); gf_out(k); 22476 gf_four(gf_dx[k]); gf_four(gf_dy[k]); 22477 end; 22478 x:=value(tfm_width[k]); 22479 if abs(x)>max_tfm_dimen then 22480 if x>0 then x:=three_bytes-1@+else x:=1-three_bytes 22481 else x:=make_scaled(x*16,internal[design_size]); 22482 gf_four(x); gf_four(char_ptr[k]); 22483 end; 22484gf_out(post_post); gf_four(gf_prev_ptr); gf_out(gf_id_byte);@/ 22485k:=4+((gf_buf_size-gf_ptr) mod 4); {the number of 223's} 22486while k>0 do 22487 begin gf_out(223); decr(k); 22488 end; 22489@<Empty the last bytes out of |gf_buf|@>; 22490print_nl("Output written on "); slow_print(output_file_name); 22491@.Output written...@> 22492print(" ("); print_int(total_chars); print(" character"); 22493if total_chars<>1 then print_char("s"); 22494print(", "); print_int(gf_offset+gf_ptr); print(" bytes)."); 22495b_close(gf_file); 22496end 22497 22498@* \[48] Dumping and undumping the tables. 22499After \.{INIMF} has seen a collection of macros, it 22500can write all the necessary information on an auxiliary file so 22501that production versions of \MF\ are able to initialize their 22502memory at high speed. The present section of the program takes 22503care of such output and input. We shall consider simultaneously 22504the processes of storing and restoring, 22505so that the inverse relation between them is clear. 22506@.INIMF@> 22507 22508The global variable |base_ident| is a string that is printed right 22509after the |banner| line when \MF\ is ready to start. For \.{INIMF} this 22510string says simply `\.{(INIMF)}'; for other versions of \MF\ it says, 22511for example, `\.{(preloaded base=plain 1984.2.29)}', showing the year, 22512month, and day that the base file was created. We have |base_ident=0| 22513before \MF's tables are loaded. 22514 22515@<Glob...@>= 22516@!base_ident:str_number; 22517 22518@ @<Set init...@>= 22519base_ident:=0; 22520 22521@ @<Initialize table entries...@>= 22522base_ident:=" (INIMF)"; 22523 22524@ @<Declare act...@>= 22525@!init procedure store_base_file; 22526var @!k:integer; {all-purpose index} 22527@!p,@!q: pointer; {all-purpose pointers} 22528@!x: integer; {something to dump} 22529@!w: four_quarters; {four ASCII codes} 22530begin @<Create the |base_ident|, open the base file, 22531 and inform the user that dumping has begun@>; 22532@<Dump constants for consistency check@>; 22533@<Dump the string pool@>; 22534@<Dump the dynamic memory@>; 22535@<Dump the table of equivalents and the hash table@>; 22536@<Dump a few more things and the closing check word@>; 22537@<Close the base file@>; 22538end; 22539tini 22540 22541@ Corresponding to the procedure that dumps a base file, we also have a function 22542that reads~one~in. The function returns |false| if the dumped base is 22543incompatible with the present \MF\ table sizes, etc. 22544 22545@d off_base=6666 {go here if the base file is unacceptable} 22546@d too_small(#)==begin wake_up_terminal; 22547 wterm_ln('---! Must increase the ',#); 22548@.Must increase the x@> 22549 goto off_base; 22550 end 22551 22552@p @t\4@>@<Declare the function called |open_base_file|@>@; 22553function load_base_file:boolean; 22554label off_base,exit; 22555var @!k:integer; {all-purpose index} 22556@!p,@!q: pointer; {all-purpose pointers} 22557@!x: integer; {something undumped} 22558@!w: four_quarters; {four ASCII codes} 22559begin @<Undump constants for consistency check@>; 22560@<Undump the string pool@>; 22561@<Undump the dynamic memory@>; 22562@<Undump the table of equivalents and the hash table@>; 22563@<Undump a few more things and the closing check word@>; 22564load_base_file:=true; return; {it worked!} 22565off_base: wake_up_terminal; 22566 wterm_ln('(Fatal base file error; I''m stymied)'); 22567@.Fatal base file error@> 22568load_base_file:=false; 22569exit:end; 22570 22571@ Base files consist of |memory_word| items, and we use the following 22572macros to dump words of different types: 22573 22574@d dump_wd(#)==begin base_file^:=#; put(base_file);@+end 22575@d dump_int(#)==begin base_file^.int:=#; put(base_file);@+end 22576@d dump_hh(#)==begin base_file^.hh:=#; put(base_file);@+end 22577@d dump_qqqq(#)==begin base_file^.qqqq:=#; put(base_file);@+end 22578 22579@<Glob...@>= 22580@!base_file:word_file; {for input or output of base information} 22581 22582@ The inverse macros are slightly more complicated, since we need to check 22583the range of the values we are reading in. We say `|undump(a)(b)(x)|' to 22584read an integer value |x| that is supposed to be in the range |a<=x<=b|. 22585 22586@d undump_wd(#)==begin get(base_file); #:=base_file^;@+end 22587@d undump_int(#)==begin get(base_file); #:=base_file^.int;@+end 22588@d undump_hh(#)==begin get(base_file); #:=base_file^.hh;@+end 22589@d undump_qqqq(#)==begin get(base_file); #:=base_file^.qqqq;@+end 22590@d undump_end_end(#)==#:=x;@+end 22591@d undump_end(#)==(x>#) then goto off_base@+else undump_end_end 22592@d undump(#)==begin undump_int(x); if (x<#) or undump_end 22593@d undump_size_end_end(#)==too_small(#)@+else undump_end_end 22594@d undump_size_end(#)==if x># then undump_size_end_end 22595@d undump_size(#)==begin undump_int(x); 22596 if x<# then goto off_base; undump_size_end 22597 22598@ The next few sections of the program should make it clear how we use the 22599dump/undump macros. 22600 22601@<Dump constants for consistency check@>= 22602dump_int(@$);@/ 22603dump_int(mem_min);@/ 22604dump_int(mem_top);@/ 22605dump_int(hash_size);@/ 22606dump_int(hash_prime);@/ 22607dump_int(max_in_open) 22608 22609@ Sections of a \.{WEB} program that are ``commented out'' still contribute 22610strings to the string pool; therefore \.{INIMF} and \MF\ will have 22611the same strings. (And it is, of course, a good thing that they do.) 22612@.WEB@> 22613@^string pool@> 22614 22615@<Undump constants for consistency check@>= 22616x:=base_file^.int; 22617if x<>@$ then goto off_base; {check that strings are the same} 22618undump_int(x); 22619if x<>mem_min then goto off_base; 22620undump_int(x); 22621if x<>mem_top then goto off_base; 22622undump_int(x); 22623if x<>hash_size then goto off_base; 22624undump_int(x); 22625if x<>hash_prime then goto off_base; 22626undump_int(x); 22627if x<>max_in_open then goto off_base 22628 22629@ @d dump_four_ASCII== 22630 w.b0:=qi(so(str_pool[k])); w.b1:=qi(so(str_pool[k+1])); 22631 w.b2:=qi(so(str_pool[k+2])); w.b3:=qi(so(str_pool[k+3])); 22632 dump_qqqq(w) 22633 22634@<Dump the string pool@>= 22635dump_int(pool_ptr); 22636dump_int(str_ptr); 22637for k:=0 to str_ptr do dump_int(str_start[k]); 22638k:=0; 22639while k+4<pool_ptr do 22640 begin dump_four_ASCII; k:=k+4; 22641 end; 22642k:=pool_ptr-4; dump_four_ASCII; 22643print_ln; print_int(str_ptr); print(" strings of total length "); 22644print_int(pool_ptr) 22645 22646@ @d undump_four_ASCII== 22647 undump_qqqq(w); 22648 str_pool[k]:=si(qo(w.b0)); str_pool[k+1]:=si(qo(w.b1)); 22649 str_pool[k+2]:=si(qo(w.b2)); str_pool[k+3]:=si(qo(w.b3)) 22650 22651@<Undump the string pool@>= 22652undump_size(0)(pool_size)('string pool size')(pool_ptr); 22653undump_size(0)(max_strings)('max strings')(str_ptr); 22654for k:=0 to str_ptr do 22655 begin undump(0)(pool_ptr)(str_start[k]); str_ref[k]:=max_str_ref; 22656 end; 22657k:=0; 22658while k+4<pool_ptr do 22659 begin undump_four_ASCII; k:=k+4; 22660 end; 22661k:=pool_ptr-4; undump_four_ASCII; 22662init_str_ptr:=str_ptr; init_pool_ptr:=pool_ptr; 22663max_str_ptr:=str_ptr; max_pool_ptr:=pool_ptr 22664 22665@ By sorting the list of available spaces in the variable-size portion of 22666|mem|, we are usually able to get by without having to dump very much 22667of the dynamic memory. 22668 22669We recompute |var_used| and |dyn_used|, so that \.{INIMF} dumps valid 22670information even when it has not been gathering statistics. 22671 22672@<Dump the dynamic memory@>= 22673sort_avail; var_used:=0; 22674dump_int(lo_mem_max); dump_int(rover); 22675p:=mem_min; q:=rover; x:=0; 22676repeat for k:=p to q+1 do dump_wd(mem[k]); 22677x:=x+q+2-p; var_used:=var_used+q-p; 22678p:=q+node_size(q); q:=rlink(q); 22679until q=rover; 22680var_used:=var_used+lo_mem_max-p; dyn_used:=mem_end+1-hi_mem_min;@/ 22681for k:=p to lo_mem_max do dump_wd(mem[k]); 22682x:=x+lo_mem_max+1-p; 22683dump_int(hi_mem_min); dump_int(avail); 22684for k:=hi_mem_min to mem_end do dump_wd(mem[k]); 22685x:=x+mem_end+1-hi_mem_min; 22686p:=avail; 22687while p<>null do 22688 begin decr(dyn_used); p:=link(p); 22689 end; 22690dump_int(var_used); dump_int(dyn_used); 22691print_ln; print_int(x); 22692print(" memory locations dumped; current usage is "); 22693print_int(var_used); print_char("&"); print_int(dyn_used) 22694 22695@ @<Undump the dynamic memory@>= 22696undump(lo_mem_stat_max+1000)(hi_mem_stat_min-1)(lo_mem_max); 22697undump(lo_mem_stat_max+1)(lo_mem_max)(rover); 22698p:=mem_min; q:=rover; 22699repeat for k:=p to q+1 do undump_wd(mem[k]); 22700p:=q+node_size(q); 22701if (p>lo_mem_max)or((q>=rlink(q))and(rlink(q)<>rover)) then goto off_base; 22702q:=rlink(q); 22703until q=rover; 22704for k:=p to lo_mem_max do undump_wd(mem[k]); 22705undump(lo_mem_max+1)(hi_mem_stat_min)(hi_mem_min); 22706undump(null)(mem_top)(avail); mem_end:=mem_top; 22707for k:=hi_mem_min to mem_end do undump_wd(mem[k]); 22708undump_int(var_used); undump_int(dyn_used) 22709 22710@ A different scheme is used to compress the hash table, since its lower region 22711is usually sparse. When |text(p)<>0| for |p<=hash_used|, we output three 22712words: |p|, |hash[p]|, and |eqtb[p]|. The hash table is, of course, densely 22713packed for |p>=hash_used|, so the remaining entries are output in~a~block. 22714 22715@<Dump the table of equivalents and the hash table@>= 22716dump_int(hash_used); st_count:=frozen_inaccessible-1-hash_used; 22717for p:=1 to hash_used do if text(p)<>0 then 22718 begin dump_int(p); dump_hh(hash[p]); dump_hh(eqtb[p]); incr(st_count); 22719 end; 22720for p:=hash_used+1 to hash_end do 22721 begin dump_hh(hash[p]); dump_hh(eqtb[p]); 22722 end; 22723dump_int(st_count);@/ 22724print_ln; print_int(st_count); print(" symbolic tokens") 22725 22726@ @<Undump the table of equivalents and the hash table@>= 22727undump(1)(frozen_inaccessible)(hash_used); p:=0; 22728repeat undump(p+1)(hash_used)(p); undump_hh(hash[p]); undump_hh(eqtb[p]); 22729until p=hash_used; 22730for p:=hash_used+1 to hash_end do 22731 begin undump_hh(hash[p]); undump_hh(eqtb[p]); 22732 end; 22733undump_int(st_count) 22734 22735@ We have already printed a lot of statistics, so we set |tracing_stats:=0| 22736to prevent them from appearing again. 22737 22738@<Dump a few more things and the closing check word@>= 22739dump_int(int_ptr); 22740for k:=1 to int_ptr do 22741 begin dump_int(internal[k]); dump_int(int_name[k]); 22742 end; 22743dump_int(start_sym); dump_int(interaction); dump_int(base_ident); 22744dump_int(bg_loc); dump_int(eg_loc); dump_int(serial_no); dump_int(69069); 22745internal[tracing_stats]:=0 22746 22747@ @<Undump a few more things and the closing check word@>= 22748undump(max_given_internal)(max_internal)(int_ptr); 22749for k:=1 to int_ptr do 22750 begin undump_int(internal[k]); 22751 undump(0)(str_ptr)(int_name[k]); 22752 end; 22753undump(0)(frozen_inaccessible)(start_sym); 22754undump(batch_mode)(error_stop_mode)(interaction); 22755undump(0)(str_ptr)(base_ident); 22756undump(1)(hash_end)(bg_loc); 22757undump(1)(hash_end)(eg_loc); 22758undump_int(serial_no);@/ 22759undump_int(x);@+if (x<>69069)or eof(base_file) then goto off_base 22760 22761@ @<Create the |base_ident|...@>= 22762selector:=new_string; 22763print(" (preloaded base="); print(job_name); print_char(" "); 22764print_int(round_unscaled(internal[year])); print_char("."); 22765print_int(round_unscaled(internal[month])); print_char("."); 22766print_int(round_unscaled(internal[day])); print_char(")"); 22767if interaction=batch_mode then selector:=log_only 22768else selector:=term_and_log; 22769str_room(1); base_ident:=make_string; str_ref[base_ident]:=max_str_ref;@/ 22770pack_job_name(base_extension); 22771while not w_open_out(base_file) do 22772 prompt_file_name("base file name",base_extension); 22773print_nl("Beginning to dump on file "); 22774@.Beginning to dump...@> 22775slow_print(w_make_name_string(base_file)); flush_string(str_ptr-1); 22776print_nl(""); slow_print(base_ident) 22777 22778@ @<Close the base file@>= 22779w_close(base_file) 22780 22781@* \[49] The main program. 22782This is it: the part of \MF\ that executes all those procedures we have 22783written. 22784 22785Well---almost. We haven't put the parsing subroutines into the 22786program yet; and we'd better leave space for a few more routines that may 22787have been forgotten. 22788 22789@p @<Declare the basic parsing subroutines@>@; 22790@<Declare miscellaneous procedures that were declared |forward|@>@; 22791@<Last-minute procedures@> 22792 22793@ We've noted that there are two versions of \MF84. One, called \.{INIMF}, 22794@.INIMF@> 22795has to be run first; it initializes everything from scratch, without 22796reading a base file, and it has the capability of dumping a base file. 22797The other one is called `\.{VIRMF}'; it is a ``virgin'' program that needs 22798@.VIRMF@> 22799to input a base file in order to get started. \.{VIRMF} typically has 22800a bit more memory capacity than \.{INIMF}, because it does not need the 22801space consumed by the dumping/undumping routines and the numerous calls on 22802|primitive|, etc. 22803 22804The \.{VIRMF} program cannot read a base file instantaneously, of course; 22805the best implementations therefore allow for production versions of \MF\ that 22806not only avoid the loading routine for \PASCAL\ object code, they also have 22807a base file pre-loaded. This is impossible to do if we stick to standard 22808\PASCAL; but there is a simple way to fool many systems into avoiding the 22809initialization, as follows:\quad(1)~We declare a global integer variable 22810called |ready_already|. The probability is negligible that this 22811variable holds any particular value like 314159 when \.{VIRMF} is first 22812loaded.\quad(2)~After we have read in a base file and initialized 22813everything, we set |ready_already:=314159|.\quad(3)~Soon \.{VIRMF} 22814will print `\.*', waiting for more input; and at this point we 22815interrupt the program and save its core image in some form that the 22816operating system can reload speedily.\quad(4)~When that core image is 22817activated, the program starts again at the beginning; but now 22818|ready_already=314159| and all the other global variables have 22819their initial values too. The former chastity has vanished! 22820 22821In other words, if we allow ourselves to test the condition 22822|ready_already=314159|, before |ready_already| has been 22823assigned a value, we can avoid the lengthy initialization. Dirty tricks 22824rarely pay off so handsomely. 22825@^dirty \PASCAL@> 22826@^system dependencies@> 22827 22828On systems that allow such preloading, the standard program called \.{MF} 22829should be the one that has \.{plain} base preloaded, since that agrees 22830with {\sl The {\logos METAFONT\/}book}. Other versions, e.g., \.{CMMF}, 22831should also be provided for commonly used bases such as \.{cmbase}. 22832@:METAFONTbook}{\sl The {\logos METAFONT\/}book@> 22833@.cmbase@> 22834@.plain@> 22835 22836@<Glob...@>= 22837@!ready_already:integer; {a sacrifice of purity for economy} 22838 22839@ Now this is really it: \MF\ starts and ends here. 22840 22841The initial test involving |ready_already| should be deleted if the 22842\PASCAL\ runtime system is smart enough to detect such a ``mistake.'' 22843@^system dependencies@> 22844 22845@p begin @!{|start_here|} 22846history:=fatal_error_stop; {in case we quit during initialization} 22847t_open_out; {open the terminal for output} 22848if ready_already=314159 then goto start_of_MF; 22849@<Check the ``constant'' values...@>@; 22850if bad>0 then 22851 begin wterm_ln('Ouch---my internal constants have been clobbered!', 22852 '---case ',bad:1); 22853@.Ouch...clobbered@> 22854 goto final_end; 22855 end; 22856initialize; {set global variables to their starting values} 22857@!init if not get_strings_started then goto final_end; 22858init_tab; {initialize the tables} 22859init_prim; {call |primitive| for each primitive} 22860init_str_ptr:=str_ptr; init_pool_ptr:=pool_ptr;@/ 22861max_str_ptr:=str_ptr; max_pool_ptr:=pool_ptr; fix_date_and_time; 22862tini@/ 22863ready_already:=314159; 22864start_of_MF: @<Initialize the output routines@>; 22865@<Get the first line of input and prepare to start@>; 22866history:=spotless; {ready to go!} 22867if start_sym>0 then {insert the `\&{everyjob}' symbol} 22868 begin cur_sym:=start_sym; back_input; 22869 end; 22870main_control; {come to life} 22871final_cleanup; {prepare for death} 22872end_of_MF: close_files_and_terminate; 22873final_end: ready_already:=0; 22874end. 22875 22876@ Here we do whatever is needed to complete \MF's job gracefully on the 22877local operating system. The code here might come into play after a fatal 22878error; it must therefore consist entirely of ``safe'' operations that 22879cannot produce error messages. For example, it would be a mistake to call 22880|str_room| or |make_string| at this time, because a call on |overflow| 22881might lead to an infinite loop. 22882@^system dependencies@> 22883 22884This program doesn't bother to close the input files that may still be open. 22885 22886@<Last-minute...@>= 22887procedure close_files_and_terminate; 22888var @!k:integer; {all-purpose index} 22889@!lh:integer; {the length of the \.{TFM} header, in words} 22890@!lk_offset:0..256; {extra words inserted at beginning of |lig_kern| array} 22891@!p:pointer; {runs through a list of \.{TFM} dimensions} 22892@!x:scaled; {a |tfm_width| value being output to the \.{GF} file} 22893begin 22894@!stat if internal[tracing_stats]>0 then 22895 @<Output statistics about this job@>;@;@+tats@/ 22896wake_up_terminal; @<Finish the \.{TFM} and \.{GF} files@>; 22897if log_opened then 22898 begin wlog_cr; 22899 a_close(log_file); selector:=selector-2; 22900 if selector=term_only then 22901 begin print_nl("Transcript written on "); 22902@.Transcript written...@> 22903 slow_print(log_name); print_char("."); 22904 end; 22905 end; 22906end; 22907 22908@ We want to finish the \.{GF} file if and only if it has already been started; 22909this will be true if and only if |gf_prev_ptr| is positive. 22910We want to produce a \.{TFM} file if and only if |fontmaking| is positive. 22911The \.{TFM} widths must be computed if there's a \.{GF} file, even if 22912there's going to be no \.{TFM}~file. 22913 22914We reclaim all of the variable-size memory at this point, so that 22915there is no chance of another memory overflow after the memory capacity 22916has already been exceeded. 22917 22918@<Finish the \.{TFM} and \.{GF} files@>= 22919if (gf_prev_ptr>0)or(internal[fontmaking]>0) then 22920 begin @<Make the dynamic memory into one big available node@>; 22921 @<Massage the \.{TFM} widths@>; 22922 fix_design_size; fix_check_sum; 22923 if internal[fontmaking]>0 then 22924 begin @<Massage the \.{TFM} heights, depths, and italic corrections@>; 22925 internal[fontmaking]:=0; {avoid loop in case of fatal error} 22926 @<Finish the \.{TFM} file@>; 22927 end; 22928 if gf_prev_ptr>0 then @<Finish the \.{GF} file@>; 22929 end 22930 22931@ @<Make the dynamic memory into one big available node@>= 22932rover:=lo_mem_stat_max+1; link(rover):=empty_flag; lo_mem_max:=hi_mem_min-1; 22933if lo_mem_max-rover>max_halfword then lo_mem_max:=max_halfword+rover; 22934node_size(rover):=lo_mem_max-rover; llink(rover):=rover; rlink(rover):=rover; 22935link(lo_mem_max):=null; info(lo_mem_max):=null 22936 22937@ The present section goes directly to the log file instead of using 22938|print| commands, because there's no need for these strings to take 22939up |str_pool| memory when a non-{\bf stat} version of \MF\ is being used. 22940 22941@<Output statistics...@>= 22942if log_opened then 22943 begin wlog_ln(' '); 22944 wlog_ln('Here is how much of METAFONT''s memory',' you used:'); 22945@.Here is how much...@> 22946 wlog(' ',max_str_ptr-init_str_ptr:1,' string'); 22947 if max_str_ptr<>init_str_ptr+1 then wlog('s'); 22948 wlog_ln(' out of ', max_strings-init_str_ptr:1);@/ 22949 wlog_ln(' ',max_pool_ptr-init_pool_ptr:1,' string characters out of ', 22950 pool_size-init_pool_ptr:1);@/ 22951 wlog_ln(' ',lo_mem_max-mem_min+mem_end-hi_mem_min+2:1,@| 22952 ' words of memory out of ',mem_end+1-mem_min:1);@/ 22953 wlog_ln(' ',st_count:1,' symbolic tokens out of ', 22954 hash_size:1);@/ 22955 wlog_ln(' ',max_in_stack:1,'i,',@| 22956 int_ptr:1,'n,',@| 22957 max_rounding_ptr:1,'r,',@| 22958 max_param_stack:1,'p,',@| 22959 max_buf_stack+1:1,'b stack positions out of ',@| 22960 stack_size:1,'i,', 22961 max_internal:1,'n,', 22962 max_wiggle:1,'r,', 22963 param_size:1,'p,', 22964 buf_size:1,'b'); 22965 end 22966 22967@ We get to the |final_cleanup| routine when \&{end} or \&{dump} has 22968been scanned. 22969 22970@<Last-minute...@>= 22971procedure final_cleanup; 22972label exit; 22973var c:small_number; {0 for \&{end}, 1 for \&{dump}} 22974begin c:=cur_mod; 22975if job_name=0 then open_log_file; 22976while input_ptr>0 do 22977 if token_state then end_token_list@+else end_file_reading; 22978while loop_ptr<>null do stop_iteration; 22979while open_parens>0 do 22980 begin print(" )"); decr(open_parens); 22981 end; 22982while cond_ptr<>null do 22983 begin print_nl("(end occurred when ");@/ 22984@.end occurred...@> 22985 print_cmd_mod(fi_or_else,cur_if); 22986 {`\.{if}' or `\.{elseif}' or `\.{else}'} 22987 if if_line<>0 then 22988 begin print(" on line "); print_int(if_line); 22989 end; 22990 print(" was incomplete)"); 22991 if_line:=if_line_field(cond_ptr); 22992 cur_if:=name_type(cond_ptr); loop_ptr:=cond_ptr; 22993 cond_ptr:=link(cond_ptr); free_node(loop_ptr,if_node_size); 22994 end; 22995if history<>spotless then 22996 if ((history=warning_issued)or(interaction<error_stop_mode)) then 22997 if selector=term_and_log then 22998 begin selector:=term_only; 22999 print_nl("(see the transcript file for additional information)"); 23000@.see the transcript file...@> 23001 selector:=term_and_log; 23002 end; 23003if c=1 then 23004 begin @!init store_base_file; return;@+tini@/ 23005 print_nl("(dump is performed only by INIMF)"); return; 23006@.dump...only by INIMF@> 23007 end; 23008exit:end; 23009 23010@ @<Last-minute...@>= 23011@!init procedure init_prim; {initialize all the primitives} 23012begin 23013@<Put each...@>; 23014end; 23015@# 23016procedure init_tab; {initialize other tables} 23017var @!k:integer; {all-purpose index} 23018begin @<Initialize table entries (done by \.{INIMF} only)@>@; 23019end; 23020tini 23021 23022@ When we begin the following code, \MF's tables may still contain garbage; 23023the strings might not even be present. Thus we must proceed cautiously to get 23024bootstrapped in. 23025 23026But when we finish this part of the program, \MF\ is ready to call on the 23027|main_control| routine to do its work. 23028 23029@<Get the first line...@>= 23030begin @<Initialize the input routines@>; 23031if (base_ident=0)or(buffer[loc]="&") then 23032 begin if base_ident<>0 then initialize; {erase preloaded base} 23033 if not open_base_file then goto final_end; 23034 if not load_base_file then 23035 begin w_close(base_file); goto final_end; 23036 end; 23037 w_close(base_file); 23038 while (loc<limit)and(buffer[loc]=" ") do incr(loc); 23039 end; 23040buffer[limit]:="%";@/ 23041fix_date_and_time; init_randoms((internal[time] div unity)+internal[day]);@/ 23042@<Initialize the print |selector|...@>; 23043if loc<limit then if buffer[loc]<>"\" then start_input; {\&{input} assumed} 23044end 23045 23046@* \[50] Debugging. 23047Once \MF\ is working, you should be able to diagnose most errors with 23048the \.{show} commands and other diagnostic features. But for the initial 23049stages of debugging, and for the revelation of really deep mysteries, you 23050can compile \MF\ with a few more aids, including the \PASCAL\ runtime 23051checks and its debugger. An additional routine called |debug_help| 23052will also come into play when you type `\.D' after an error message; 23053|debug_help| also occurs just before a fatal error causes \MF\ to succumb. 23054@^debugging@> 23055@^system dependencies@> 23056 23057The interface to |debug_help| is primitive, but it is good enough when used 23058with a \PASCAL\ debugger that allows you to set breakpoints and to read 23059variables and change their values. After getting the prompt `\.{debug \#}', you 23060type either a negative number (this exits |debug_help|), or zero (this 23061goes to a location where you can set a breakpoint, thereby entering into 23062dialog with the \PASCAL\ debugger), or a positive number |m| followed by 23063an argument |n|. The meaning of |m| and |n| will be clear from the 23064program below. (If |m=13|, there is an additional argument, |l|.) 23065@.debug \#@> 23066 23067@d breakpoint=888 {place where a breakpoint is desirable} 23068 23069@<Last-minute...@>= 23070@!debug procedure debug_help; {routine to display various things} 23071label breakpoint,exit; 23072var @!k,@!l,@!m,@!n:integer; 23073begin loop begin wake_up_terminal; 23074 print_nl("debug # (-1 to exit):"); update_terminal; 23075@.debug \#@> 23076 read(term_in,m); 23077 if m<0 then return 23078 else if m=0 then 23079 begin goto breakpoint;@\ {go to every label at least once} 23080 breakpoint: m:=0; @{'BREAKPOINT'@}@\ 23081 end 23082 else begin read(term_in,n); 23083 case m of 23084 @t\4@>@<Numbered cases for |debug_help|@>@; 23085 othercases print("?") 23086 endcases; 23087 end; 23088 end; 23089exit:end; 23090gubed 23091 23092@ @<Numbered cases...@>= 230931: print_word(mem[n]); {display |mem[n]| in all forms} 230942: print_int(info(n)); 230953: print_int(link(n)); 230964: begin print_int(eq_type(n)); print_char(":"); print_int(equiv(n)); 23097 end; 230985: print_variable_name(n); 230996: print_int(internal[n]); 231007: do_show_dependencies; 231019: show_token_list(n,null,100000,0); 2310210: slow_print(n); 2310311: check_mem(n>0); {check wellformedness; print new busy locations if |n>0|} 2310412: search_mem(n); {look for pointers to |n|} 2310513: begin read(term_in,l); print_cmd_mod(n,l); 23106 end; 2310714: for k:=0 to n do print(buffer[k]); 2310815: panicking:=not panicking; 23109 23110@* \[51] System-dependent changes. 23111This section should be replaced, if necessary, by any special 23112modifications of the program 23113that are necessary to make \MF\ work at a particular installation. 23114It is usually best to design your change file so that all changes to 23115previous sections preserve the section numbering; then everybody's version 23116will be consistent with the published program. More extensive changes, 23117which introduce new sections, can be inserted here; then only the index 23118itself will get a new section number. 23119@^system dependencies@> 23120 23121@* \[52] Index. 23122Here is where you can find all uses of each identifier in the program, 23123with underlined entries pointing to where the identifier was defined. 23124If the identifier is only one letter long, however, you get to see only 23125the underlined entries. {\sl All references are to section numbers instead of 23126page numbers.} 23127 23128This index also lists error messages and other aspects of the program 23129that you might want to look up some day. For example, the entry 23130for ``system dependencies'' lists all sections that should receive 23131special attention from people who are installing \MF\ in a new 23132operating environment. A list of various things that can't happen appears 23133under ``this can't happen''. 23134Approximately 25 sections are listed under ``inner loop''; these account 23135for more than 60\pct! of \MF's running time, exclusive of input and output. 23136