(*$b0*) program tyldvidvi(input,output); (* ---------------------------------------------------------- TeXtyl line-drawing interface for TeX. copyright (c) 1987 John S. Renner All rights reserved. ABSTRACT: TeXtyl reads in a DVI file, and processes 'specials' that refer to graphics capabilities that it knows about, like line, spline, ThickThinSpline, and musical beams and slurs. TeXtyl then outputs a new DVI file, with the special-macros expanded and converted to DVI-commands for character setting. DEPENDENCIES: Few assumptions about Pascal are assumed. All identifiers are unique to eight characters. There are notes to indicate system-dependencies. I assume the standard definition of "READ(fil, x)" to be equivalent to "x := fil^; GET(fil)" , and "WRITE(fil, x)" == "fil^ := x; PUT(fil)" . Arrays are passed by reference (VAR) for efficiency. See also the "sysdependent" procedure; Problem areas, or areas for expansion are marked with ### -------------------------------------------------------------*) (* Revision History: Jun. 1986 v1.0 Basic version of TeXtyl Dec. 1986 v1.1 Added adaptive subdivision for spline interpolation. Added Cardinal basis. Mar. 1987 v1.2 Added F and W flags for beginfigure to allow required and/or actual dimensions to interface with files output by the DP drawing program from Carnegie-Mellon also various fixes Apr. 1987 v1.3 Added linestyles (dotted, dashed, dotdashed) *) label 666, 30; (*=====================CONST============================*) #include "tylext.h" #include "texpaths.h" const TylVersion = 'This is TeXtyl, Version 1.30'; (* for dvi-commands *) PUT1 = 133; SET1 = 128; PUTRULE = 137; NOP = 138; PUSH = 141; POP = 142; RIGHTLEFT = 143; DOWNUP = 157; FONTDEF = 244; USEFONT = 236; OURFONTFLAG = 256; (* our special 'byte' value flag *) USESTDAREA = 0; (* flag to use the 'standard' area to find .tfm files *) (* some conversions and numbers *) SPPERPT = 65536; (* scaled points per printers point *) SPPERMM = 186468; (* scaled pts per millimetre *) RADTODEG = 57.29577952; (* degrees per radian *) DEGTORAD = 0.0174532925; (* radians per degree *) PI = 3.141592654; TWO16 = 65536; (* 2 ^ 16 *) TWO20 = 1048576; (* 2 ^ 20 *) TWO23 = 8388608; TWO24 = 16777216; TWO27 = 134217728; TWO31 = 2147483647; (* 2^31 - 1 *) BIGREAL = 1.0e30; MAXVECLENsp = 262144; (* Normal maximum length of longest * vector-font character in scaled points *) (* Music Font dependent constants *) DOTCHAR = 127; (* ascii number of char that is a dot *) QNOTEGHUS = 18.0; (* MF: Global Horizontal Units for a Quarternote *) QNOTEGVUS = 16.0; (* MF: Global Vertical units for a quarternote *) GBMGHUS = 12.0; (* MF: horizontal units for a grace beam *) GBMGVUS = 9.0; BMSTART = 0; BMEND = 69; (* indices for start/end of the beam chars *) LOBM1 = 0; (* indices for the regular beam chars that *) HIBM1 = 34; (* are 1 quarternote long, and *) LOBM1p5 = 35; (* for those that are 1.5 quarternotes long *) HIBM1p5 = 69; GBMSTART = 70; GBMEND = 105; (* indices for the grace beams *) LOGBMp5 = 70; (* indices for grace beam chars that *) HIGBMp5 = 87; (* are 0.5 grace quarternote long, and *) LOGBMp66 = 88; (* 0.66 grace quarternotes long *) HIGBMp66 = 105; LoVThick = 1; (* Bounds for Vector char thicknesses *) HiVThick = 13; SizVFontTable = 39; (* size of the Vector Font Table *) { 3*HiVThick } SizMFontTable = 18;(* size of the Music Font Table *) MAXLABELFONTS = 5; SizLFontTable = MAXLABELFONTS; (* size of the Label Font Table *) MAXCTLPTS = 63; (* max number of control points *) MAXCTLPTSp3 = 66; (* max control points + 3 *) ARRLIMIT = 100; (* limit for strings and other arrays *) MAXSPLINESEGS = 480; (* max number of spline segments *) MAXOLEN = 128; (* max length of Ostring that holds bytes of dvi cmds *) MAXTBDs = 50; (* max number of Fonts-to-be-Defined *) MAXDVISTRINGS = 600; (* max number of DVI Ostrings per page *) TFMSIZE = 8000; (* size of TFM array to hold .tfm file info *) (* Numeric names for the TeXtyl primitives *) Aline = 1; (* should be first *) Aspline = 2; Attspline = 3; Abeam = 4; Atieslur = 5; Aarc = 6; Alabel = 7; Afigure = 8; (* should be last one *) MAXFONTS = 60; (* number of TeX fonts to keep track of *) STACKSIZE = 50; (* size of stack for pushes and pops *) AREALENGTH = TYLPATHLEN; (* see also "sysdependent" proc for this value*) CR = 13; (* numbers of certain ascii characters *) LF = 10; HT = 9; FF = 12; ERRSIGNAL = '?'; ERRNOTBAD = 0; ERRBAD = 1; ERRREALBAD = 2; READACCESS = 4; WRITEACCESS = 2; NOPATH = 0; FONTPATH = 3; (*===========================TYPES=============================*) type (* ---- Bytes ---- *) Inbyt = -128 .. 127; OctByt = 0 .. 256; (* DVI commands are 0..255, but we need one more for an internal flag *) bytefile = packed file of Inbyt; (* ---- Strings ---- *) asciicode = 32 .. 126; charstring = packed array [1 .. ARRLIMIT] of char; ascstring = packed array [1 .. ARRLIMIT] of asciicode; (* rep for character strings *) strng = record len: 0 .. ARRLIMIT; str:charstring; end; (* rep for ascii strings *) astrng = record len: 0 .. ARRLIMIT; str: ascstring; end; (* byte strings *) pOstring = ^Ostring; Ostring = packed array[1 .. MAXOLEN] of OctByt; (* ---- PUBLIC types ---- *) VThickness = LoVThick .. HiVThick; VectKind = (VKCirc, VKVert, VKHort); BeamKind = (regular, grace); SplineKind = (BSPL, INTBSPL, CATROM, CARD); LineStyle = (solid, dotted, dashed, dotdash); ScaledPts = integer; MusIndex = integer; VecIndex = integer; ThickAryType = array[0 .. MAXSPLINESEGS] of VThickness; SplineSegments = array[1 .. MAXSPLINESEGS, 1 .. 2] of ScaledPts; ControlPoints = array [0 .. MAXCTLPTSp3, 1 .. 2] of ScaledPts; (* ----- Private Types ---- *) FontInfRec = record Cht, Cdp, Cwd : ScaledPts; Angle : real; end; pVectFontInfRec = ^VectFontInfRec; (* vector font info *) VectFontInfRec = record vkind : VectKind; DesSize : ScaledPts; PenSize : ScaledPts; psize : VThickness; MaxVectLen : ScaledPts; FontName : strng; Cksum : integer; Isdefined : boolean; DVIFontNum: integer; FontInfo : array [0 .. 127] of FontInfRec; end; pMusFontInfRec = ^MusFontInfRec; (* music font info *) MusFontInfRec = record DesSize : ScaledPts; Family : integer; FontName : strng; Cksum : integer; Isdefined : boolean; DVIFontNum: integer; Staffsize : integer; ghu : ScaledPts; gvu : ScaledPts; FontInfo : array [0 .. 127] of FontInfRec; end; pLabFontInfRec = ^LabFontInfRec; (* label fonts info *) LabFontInfRec = record DesSize : ScaledPts; FontName : strng; Cksum : integer; Isdefined : boolean; DVIFontNum : integer; internalnumber : integer; spacewidth : ScaledPts; end; (* list of dvi-strings *) dvistary = array[1 .. MAXDVISTRINGS] of pOstring; DVIBuftype = record TotByteLen : integer; Numstrings : integer; curstrindex : integer; Dstrings : dvistary; end; (* representation of list of fonts that have to be defined * before we output the BOP of the page we * just scanned *) ToBeDefinedRec = record which : char; indx : integer; end; stackrec = record sh, sv, sw, sx, sy, sz: integer; end; Stacktype = array [0 .. STACKSIZE] of stackrec; Oneby4Vector = array[1 .. 4] of real; Fourby4Matrix = array[1 .. 4, 1 .. 4] of real; Oneby5Vector = array[1 .. 5] of real; Primitive = Aline .. Afigure; pItem = ^Item; figptr = ^Figure; Item = packed record nextitem : pItem; BBlx, BBby, BBrx, BBty : ScaledPts; (* Bounding box *) itemthick : VThickness; itemvec : VectKind; itempatt : LineStyle; case kind : Primitive of Aline : ( lx1, ly1, lx2, ly2 : ScaledPts; ); Aspline : ( spltype : SplineKind; sclosed : boolean; dosmarks : integer; nsplknots : integer; spts : ControlPoints; ); Attspline : ( tspltype : SplineKind; tclosed : boolean; dottmarks : integer; nttknots : integer; ttpts : ControlPoints; ttarry : ThickAryType; ); Abeam : ( bx1, by1, bx2, by2 : ScaledPts; staf : integer; bkind : BeamKind; ); Atieslur : ( ntknots : integer; minth, maxth : VThickness; tspts : ControlPoints; ); Aarc : ( acentx, acenty : ScaledPts; aradius : ScaledPts; firstang, lastang : integer; narcknots : integer; arcpts : ControlPoints; ); Alabel : ( labx, laby : ScaledPts; fontstyle : integer; labeltext : strng; ); Afigure : ( figtheta : real; fsx, fsy : real; fdx, fdy : ScaledPts; preWid, preHt : ScaledPts; postWid, postHt : ScaledPts; depthnumber : integer; body : figptr; ); end; Figure = record things : pItem; end; (*==============================VARS============================*) var (* ----- Private vars *) catrommtx : Fourby4Matrix; (* basis matrix for catmul-rom splines*) bsplmtx : Fourby4Matrix; (* basis matrix for B-splines *) cardmtx : Fourby4Matrix; (* Cardinal spline matrix *) lastPoint : integer; (* num of output points *) intervals : integer; (* count of spline interval we are on *) ourxpos, (* internal x-position on page *) ourypos, (* internal y-position on page *) ourfontnum : integer; (* internal number of TeX font currently in use*) ourpushdepth : integer; (* depth of internal pushes *) origTexfont : integer; (* number of TeX font in use before tyling *) GDVIBuf : DVIBuftype; (* Global DVI buffer that contains a list of * dvi commands for this page. All dvi-cmds * parsed are put here and possibly modified * before being written to the output file *) VFontTable : array [1 .. SizVFontTable] of pVectFontInfRec; MFontTable : array [1 .. SizMFontTable] of pMusFontInfRec; LFontTable : array [1 .. SizLFontTable] of pLabFontInfRec; (* the font tables, and the number of fonts defined in each *) VFontsDefd, MFontsDefd, LFontsDefd : integer; GDVIFN : integer; (* dvi font number currently in use *) (* table of fonts yet To-Be-Defined *) TBD : array[1 .. MAXTBDs] of ToBeDefinedRec; FTBDs : integer; (* number of fonts to be defined for current page *) pageitems : pItem; (* list of primitives in current use in the current * figure on the current page *) TotBytesWritten : integer; ourq : integer; (* the 'q' for the postpost *) specstart: integer; (* the place in the DVI buffer where the * start of the special begins. * this is so that we know how far to back up * and over-write the old \special macro string * with the cmds of our 'macro-expansion' *) multifigure : integer; (* depth of definition recursion of figures *) didnewfonts : boolean; (* did we define the new fonts for this page? *) prevfont : integer; (* to keep track of prev font before the * PUSH and expansion of the special *) pgfigurenum : integer; (* figure number for this page *) currpagenum : integer; (* number of page we are on *) skiptsclamp : boolean; (* DEBUG: should we skip post-clamping ties *) dviBBlx, dviBBrx, (* Bounding box of figure in DVI space *) dviBBby, dviBBty : ScaledPts; ErrorOccurred : boolean; (* global flag in case some error happened *) thefilename, realnameoffile : charstring; (* used externally *) (* ----- End private vars *) tfmbyte : Inbyt; vaxbyt : Inbyt; tfm: array[-100 .. TFMSIZE] of OctByt; xord: array [char] of asciicode; xchr: array [0 .. 255] of char; outname: strng; (* name of output file *) tfmname : strng; (* name of a .tfm file *) dvifname : strng; (* name of the input dvi file *) logfilnam: strng; (* name of the log file *) dvifile: bytefile; tfmfile: bytefile; outputfil: bytefile; logfile : text; curfont: integer; s : 0 .. STACKSIZE; h, v, w, x, y, z: integer; stack: Stacktype; font: array [0 .. MAXFONTS] of record num: integer; name: astrng; checksum: integer; scaledsize: integer; designsize: integer; space: integer; bc: integer; ec: integer; widths: array [0 .. 127] of ScaledPts end; nf : 0 .. MAXFONTS; MINREAL : real; (* a system-dependent 'constant' *) b0, b1, b2, b3: OctByt; inwidth: array [0 .. 255] of integer; tfmchecksum: integer; conv: real; trueconv: real; numerator, denominator: integer; defaultdirectory: strng; mag, magfactor: real; maxv, maxh, maxs : integer; maxpages, totalpages : integer; resolution: real; inpostamble : boolean; newbackptr, oldbackptr : integer; p, k : integer; waste : integer; (* ==================forward declarations============================ *) { These hooks assume that the parameters are filled "correctly", and are already transformed into 4th Quadrant DVI-space } procedure TylTieSlur (var KnotArray: ControlPoints; numknots: integer; minthick, maxthick: VThickness); forward; procedure TylThickThinSpline (thetype : SplineKind; isclosed : boolean; var KnotArray: ControlPoints; var ThikThinAry: ThickAryType; numknots: integer; vec: VectKind; patt: LineStyle; domarks : integer); forward; procedure TylSpline (thetype : SplineKind; isclosed : boolean; var KnotArray: ControlPoints; numknots: integer; thick: VThickness; vec: VectKind; patt: LineStyle; domarks : integer); forward; procedure TylLine (xl, yb, xr, yt: ScaledPts; thickness: VThickness; vec: VectKind; patt: LineStyle); forward; procedure TylBeam (fromx, fromy, tox, toy: ScaledPts; staffsize : integer; kind : BeamKind); forward; procedure TylArc (radius : ScaledPts; centx, centy : ScaledPts; firstangle, secondangle : integer; thick : VThickness; vec : VectKind; patt: LineStyle); forward; procedure TylLabel (xpos, ypos : ScaledPts; fontstyle : integer; phrase : charstring; phraselen : integer); forward; (* private procedures *) procedure definebeams (var M : pMusFontInfRec); forward; procedure definevectors (var Vec: pVectFontInfRec); forward; procedure defineNewfonts; forward; procedure doTylArc (iscircle : boolean; var apts : ControlPoints; numknots : integer; thick : VThickness; vec : VectKind; patt : LineStyle); forward; procedure strcopy (src : charstring; var dest : charstring; len : integer); forward; procedure writestrng (s :strng; tologfile : boolean); forward; (* end private procs *) {------------------------------------------------------} procedure jumpout; begin goto 666; (* global label *) end; (*-------------- System Dependent stuff ----------------------*) (* the default-directory should be where the .tfm files are * to be found. the string len should reflect this name. * Check with the local site maintainer about any necessary * additions to the reset and rewrite procedures for opening * 8-bit binary files. *) procedure sysdependent; begin setpaths; defaultdirectory.str := TYLPATH; defaultdirectory.len := TYLPATHLEN; (* AREALENGTH const should be this, too *) writeln(TylVersion,' for Berkeley Unix'); resolution := 300.0; (* just a number *) MINREAL := 1.0e-20; (* so that we avoid some underflows *) end; {------------------------------------------------------------} procedure complain (severity :integer); begin writeln(logfile,'Error in fig#',pgfigurenum:0,' on page ',currpagenum:0); case severity of ERRNOTBAD : begin write (ERRSIGNAL); end; ERRBAD : begin write (ERRSIGNAL); ErrorOccurred := true; end; ERRREALBAD : begin write (ERRSIGNAL,'! '); ErrorOccurred := true; end; end; (* case *) end; function opendvifile : boolean; begin strcopy (dvifname.str, thefilename, dvifname.len); thefilename[dvifname.len + 1] := ' '; if (testaccess (READACCESS, NOPATH)) then begin reset (dvifile, realnameoffile); opendvifile := true; end else begin writestrng(dvifname, false); writeln(' : DVI file not found/readable '); opendvifile := false; end; end; function opentfmfile : boolean; begin strcopy (tfmname.str, thefilename, tfmname.len); thefilename[tfmname.len + 1] := ' '; if (testaccess (READACCESS, FONTPATH)) then begin reset(tfmfile, realnameoffile); opentfmfile := true; end else begin writestrng(tfmname, false); writeln(' : TFM file not fount/readable '); opentfmfile := false; end; end; procedure openoutputfile; begin strcopy (outname.str, thefilename, outname.len); thefilename[outname.len + 1] := ' '; if (testaccess (WRITEACCESS, NOPATH)) then rewrite (outputfil, realnameoffile) else begin writestrng(outname, false); writeln(' : Output file not writable'); jumpout; end; end; procedure openlogfile; begin strcopy (logfilnam.str, thefilename, logfilnam.len); thefilename[logfilnam.len + 1] := ' '; if (testaccess (WRITEACCESS, NOPATH)) then rewrite (logfile, realnameoffile) else begin writestrng(logfilnam, false); writeln(' : Log file not writable'); jumpout; end; end; (* &&Module Tylsupport *) {---------------------------------------------------} procedure ClearBufString (var s : pOstring); (* clear a DVI buffer string to contain no-ops*) var i : integer; begin for i := 1 to MAXOLEN do s^[i] := NOP; end; {---------------------------------------------------} function NewBufString : pOstring; var s : pOstring; begin new (s); ClearBufString (s); NewBufString := s; end; (* NOTATION:: * All procedures that put a dvi-command into the * temporary buffer are prefixed with "cmd"... * Functions that deal with reading .tfm files are prefixed * with "T" or have "tfm" in their names. * Functions that deal with reading DVI files are * prefixed with a "D". *) {--------------------------------------------} procedure cmd1byte (cmd : OctByt); begin with GDVIBuf do begin if (Numstrings > MAXDVISTRINGS) then (* buffer full *) begin complain (ERRREALBAD); writeln (logfile,'error: too many dvistrings. Totbytes = ',TotByteLen); jumpout; end; if (curstrindex > MAXOLEN) then (* current string full *) begin Numstrings := Numstrings + 1; if (Dstrings[Numstrings] <> nil) then dispose (Dstrings[Numstrings]); Dstrings[Numstrings] := NewBufString; ClearBufString(Dstrings[Numstrings]); curstrindex := 1; end; Dstrings[Numstrings]^[curstrindex] := cmd; (* insert command byte *) TotByteLen := TotByteLen + 1; curstrindex := curstrindex + 1; end; end; {---------------------------------------------------} procedure cmd2byte (cmd : integer); begin cmd1byte (cmd div 256); cmd1byte (cmd mod 256); end; {---------------------------------------------------} procedure cmd3byte (cmd : integer); begin cmd1byte (cmd div TWO16); cmd1byte ((cmd div 256) mod 256); cmd1byte (cmd mod 256); end; {---------------------------------------------------} procedure cmd4byte (cmd : integer); var tmp : integer; begin tmp := cmd; if (tmp >= 0) then begin cmd1byte (tmp div TWO24); end else begin tmp := tmp + TWO31 + 1; (* need the +1 *) cmd1byte (tmp div TWO24 + 128); end; tmp := tmp mod TWO24; cmd1byte (tmp div TWO16); tmp := tmp mod TWO16; cmd1byte (tmp div 256); cmd1byte (tmp mod 256); end; {---------------------------------------------------} (* ### may be system dependent as integers are assumed to be signed 32-bits *) procedure cmdSigned (i : integer; numbytes: integer); var tmp : integer; begin if (numbytes = 4) then cmd4byte (i) else begin (* <= 3 bytes *) tmp := i; if (numbytes = 3) then begin if (tmp < 0) then tmp := tmp + TWO24; cmd1byte (tmp div TWO16); tmp := tmp mod TWO16; cmd1byte (tmp div 256); end; if (numbytes = 2) then begin if (tmp < 0) then tmp := tmp + TWO16; cmd1byte (tmp div 256); end; if (numbytes = 1) then begin if (tmp < 0) then tmp := tmp + 256; end; cmd1byte (tmp mod 256); (* for all *) end; end; {---------------------------------------------------} function Tgetvaxbyte : OctByt; label 9999; begin tfmbyte := tfmfile^; if (tfmbyte < 0) then Tgetvaxbyte := tfmbyte + 256 else Tgetvaxbyte := tfmbyte; if (eof (tfmfile)) then begin complain (ERRREALBAD); writeln (logfile,' early EOF of tfm file! '); goto 9999; end; get (tfmfile); 9999: end; {---------------------------------------------------} procedure readtfmword; begin b0 := Tgetvaxbyte; b1 := Tgetvaxbyte; b2 := Tgetvaxbyte; b3 := Tgetvaxbyte; end; {---------------------------------------------------} function DVaxByte : OctByt; label 99; begin vaxbyt := dvifile^; if (eof (dvifile)) then begin DVaxByte := 0; goto 99; end; if (vaxbyt < 0) then DVaxByte := vaxbyt + 256 else DVaxByte := vaxbyt; get (dvifile); 99: end; {---------------------------------------------------} (* get a byte from the DVI file, but do not copy it into the DVIbuffer *) function Dgrabbyte : integer; var b: OctByt; begin if eof(dvifile) then Dgrabbyte := 0 else begin b := DVaxByte; Dgrabbyte := b; end; end; {---------------------------------------------------} function Dget1byte : integer; var b: OctByt; begin if eof(dvifile) then Dget1byte := 0 else begin b := DVaxByte; Dget1byte := b end; cmd1byte(b); end; {---------------------------------------------------} function Dsign1byte : integer; var b: OctByt; begin b := DVaxByte; if b < 128 then Dsign1byte := b else Dsign1byte := b - 256; cmd1byte(b); end; {---------------------------------------------------} function Dget2byte : integer; var a, b: OctByt; begin a := DVaxByte; b := DVaxByte; Dget2byte := a * 256 + b; cmd1byte(a); cmd1byte(b); end; {---------------------------------------------------} function Dsign2byte : integer; var a, b: OctByt; begin a := DVaxByte; b := DVaxByte; if a < 128 then Dsign2byte := a * 256 + b else Dsign2byte := (a - 256) * 256 + b; cmd1byte(a); cmd1byte(b); end; {---------------------------------------------------} function Dget3byte : integer; var a, b, c: OctByt; begin a := DVaxByte; b := DVaxByte; c := DVaxByte; Dget3byte := (a * 256 + b) * 256 + c; cmd1byte(a); cmd1byte(b); cmd1byte(c); end; {---------------------------------------------------} function Dsign3byte : integer; var a, b, c: OctByt; begin a := DVaxByte; b := DVaxByte; c := DVaxByte; if a < 128 then Dsign3byte := (a * 256 + b) * 256 + c else Dsign3byte := ((a - 256) * 256 + b) * 256 + c; cmd1byte(a); cmd1byte(b); cmd1byte(c); end; {---------------------------------------------------} function Dsign4byte : integer; var a, b, c, d: OctByt; begin a := DVaxByte; b := DVaxByte; c := DVaxByte; d := DVaxByte; if a < 128 then Dsign4byte := ((a * 256 + b) * 256 + c) * 256 + d else Dsign4byte := (((a - 256) * 256 + b) * 256 + c) * 256 + d; cmd1byte(a); cmd1byte(b); cmd1byte(c); cmd1byte(d); end; {---------------------------------------------------} (* write a byte out to the ouput file, but if we * encounter the font flag, define the new fonts, and * continue *) procedure OutputByte (b : OctByt); var x : Inbyt; n : integer; begin n := b; if (n = OURFONTFLAG) then begin (* our special macro-flag *) n := NOP; (* nullify it *) if (not didnewfonts) then begin didnewfonts := true; defineNewfonts; (* expand the defns in the outfile itself *) end; end; (* if *) if (n > 127) then begin x := n - 256; end else x := n; outputfil^ := x; put (outputfil); TotBytesWritten := TotBytesWritten + 1; (* keep count of all bytes *) end; {---------------------------------------------------} procedure Output2Byte (i : integer); begin OutputByte (i div 256); OutputByte (i mod 256); end; {---------------------------------------------------} procedure Output4Byte (i : integer); var tmp : integer; begin tmp := i; if (tmp >= 0) then begin OutputByte (tmp div TWO24); end else begin tmp := tmp + TWO31 + 1; (* need the +1 *) OutputByte (tmp div TWO24 + 128); end; tmp := tmp mod TWO24; OutputByte (tmp div TWO16); tmp := tmp mod TWO16; OutputByte (tmp div 256); OutputByte (tmp mod 256); end; {---------------------------------------------------} function rtan (ang : real) : real; var rads : real; cosrads : real; begin rads := ang * DEGTORAD; cosrads := cos (rads); if (cosrads = 0.0) then { this happens at 90 and 270 } cosrads := cos ((ang - 0.01) * DEGTORAD); rtan := (sin (rads)) / (cosrads); end; {---------------------------------------------------} function float (i : integer) : real; begin float := i + 0.00; end; {---------------------------------------------------} function tolowercase (let: char) : char; const Diff = 32; (* xord['a'] - xord['A'] *) var olet : integer; begin olet := xord[let]; if (olet >= xord['A']) then begin if (olet <= xord['Z']) then begin let := xchr[olet + Diff]; end; end; tolowercase := let; end; {---------------------------------------------------} (* decide if the first string is the same as the second -- * at least the first 'len' characters * We need this since most Pascal impls. are brain-dead * when it comes to string comparisons *) function streq (a, b : charstring; len : integer) : boolean; label 1; var i : integer; same : boolean; begin same := true; for i := 1 to len do begin if (a[i] <> b[i]) then begin same := false; goto 1; end; (* if *) end; (* for *) 1: streq := same; end; (* streq *) {-------------------------------------------------------} procedure strcopy (* src : charstring; var dest : charstring; len : integer *); var i : integer; begin for i := 1 to len do dest[i] := src[i]; end; {-------------------------------------------------------} procedure writestrng (* s :strng; tologfile : boolean *); var i : integer; begin if (tologfile) then begin for i := 1 to s.len do write (logfile, s.str[i]); end else begin for i := 1 to s.len do write (s.str[i]); end; end; {---------------------------------------------------} (* Move the current DVI position to posx, posy by * moving relatively from our current position * and store the new position *) procedure isetpos (posx, posy : integer); var dy, dx: ScaledPts; numbytes : integer; begin dx := posx - ourxpos; dy := posy - ourypos; numbytes := 1; if ((dx < 128) and (dx >= -128)) then numbytes := 1 else if ((dx < 32768) and (dx >= -32768)) then numbytes := 2 else if ((dx < TWO23) and (dx >= - TWO23))then numbytes := 3 else if ((dx < TWO31) and (dx >= - TWO31))then numbytes := 4 else begin complain (ERRREALBAD); writeln('Panic: dx is too big/small in isetpos: ',dx); writeln(logfile,'Panic: dx is too big/small in isetpos: ',dx); end; cmd1byte (RIGHTLEFT + numbytes -1); (* number of bytes in its arg list *) cmdSigned (dx, numbytes); numbytes := 1; if ((dy < 128) and (dy >= -128)) then numbytes := 1 else if ((dy < 32768) and (dy >= -32768)) then numbytes := 2 else if ((dy < TWO23) and (dy >= - TWO23))then numbytes := 3 else if ((dy < TWO31) and (dy >= - TWO31))then numbytes := 4 else begin complain (ERRREALBAD); writeln('Panic: dy is too big/small in isetpos: ',dy); writeln(logfile,'Panic: dy is too big/small in isetpos: ',dy); end; cmd1byte (DOWNUP + numbytes -1); cmdSigned (dy, numbytes); ourxpos := posx; ourypos := posy; end; {---------------------------------------------------} (* put out a character *) procedure iputchar (charno : OctByt); begin cmd1byte (PUT1); cmd1byte (charno); end; {---------------------------------------------------} (* set the font number, but only if it is different than * the last one we accessed. *) procedure isetfont (DVINum : integer); begin if (ourfontnum <> DVINum) then begin cmd1byte (USEFONT); cmd2byte (DVINum); ourfontnum := DVINum; end; end; procedure IPUSH; begin if (ourpushdepth = 0) then begin (* first push --> start tyling *) origTexfont := font[curfont].num; end else begin prevfont := ourfontnum; (* store the internal font number in use at this time *) end; cmd1byte (NOP); cmd1byte (NOP); (* our greeting *) cmd1byte (PUSH); ourpushdepth := ourpushdepth + 1; end; procedure IPOP; begin cmd1byte (POP); cmd1byte(NOP); cmd1byte(NOP); (* our signature *) ourpushdepth := ourpushdepth - 1; if (ourpushdepth < 0) then begin complain (ERRREALBAD); writeln(logfile,'Error: too many internal pops'); end; if (ourpushdepth = 0) then begin (* we are totally done with tyling for now *) if (nf > 0) then isetfont (origTexfont); (* only if it is valid *) end else begin if (prevfont >= 0) then isetfont(prevfont); (* restore that internal font previously in use *) end; end; {---------------------------------------------------} (* Assumes that the correct font is currently set *) procedure Tyldot (dotx, doty : ScaledPts); begin if (dotx <> 0) and (doty <> 0) then isetpos (dotx, doty); iputchar (DOTCHAR); end; {---------------------------------------------------} procedure InitDVIBuf; var i: integer; begin with GDVIBuf do begin TotByteLen := 0; Numstrings := 0; for i := 1 to MAXDVISTRINGS do Dstrings[i] := nil; curstrindex := MAXOLEN + 1; end; end; {---------------------------------------------------} procedure ClearDVIBuf; var i : integer; begin with GDVIBuf do begin for i := 1 to Numstrings do begin dispose (Dstrings[i]); Dstrings[i] := nil; end; TotByteLen := 0; Numstrings := 0; curstrindex := MAXOLEN + 1; end; end; {---------------------------------------------------} procedure WriteDVIBuf; var i: integer; curstr: integer; b : OctByt; begin curstr := 1; with GDVIBuf do begin while (curstr < Numstrings) do begin for i := 1 to MAXOLEN do begin b := Dstrings[curstr]^[i]; OutputByte (b); end; curstr := curstr + 1; end; (* while *) (* now do the last string *) for i := 1 to (curstrindex - 1) do begin b := Dstrings[Numstrings]^[i]; OutputByte(b); end; (* for *) end; (* with *) ClearDVIBuf; end; {---------------------------------------------------} procedure BackupInBuf (nbytes : integer); var nstrs, rem : integer; begin with GDVIBuf do begin nstrs := (TotByteLen - nbytes) div MAXOLEN; rem := (TotByteLen - nbytes) mod MAXOLEN; Numstrings := nstrs + 1; curstrindex := rem + 1; (* points to position to-be-filled *) if (curstrindex = 0) then curstrindex := MAXOLEN; TotByteLen := TotByteLen - nbytes; end; end; {-----------------------------------------------------} function DVIMark : integer; begin DVIMark := GDVIBuf.TotByteLen; end; {---------------------------------------------} function NewItem (what : Primitive): pItem; var i : pItem; f : figptr; begin new (i); with i^ do begin nextitem := nil; BBlx := 0; BBby := 0; BBrx := 0; BBty := 0; itemthick := LoVThick; itemvec := VKCirc; itempatt := solid; kind := what; case (what) of (* give defaults *) Aline : ; Aspline: begin nsplknots := 0; dosmarks := 0; sclosed := false; spltype := BSPL; end; Attspline: begin nttknots := 0; dottmarks := 0; tspltype := BSPL; tclosed := false; end; Abeam : ; Atieslur: begin ntknots := 0; end; Aarc: begin narcknots := 0; end; Alabel: begin fontstyle := -1; (* undefined *) labeltext.len := 0; end; Afigure: begin figtheta := 0.0; fsx := 1.0; fsy := 1.0; fdx := 0; fdy := 0; preWid := 0; preHt := 0; postWid := 0; postHt := 0; depthnumber := 0; (* for now *) new (f); (* a new figure *) body := f; body^.things := nil; end; end; (*case *) end; (* with *) NewItem := i; end; (* NewItem *) { ### Note: "pageitems" could be extended to be a list { of macrodefinitions which contain primitives , and { then could be instanced. E.g., a library of common { figures callable from \special level } {------------------------------------------------------} procedure pushItem (depth : integer; newthing : pItem); label 101; var i, p : pItem; dun : boolean; begin if (pageitems = nil) then begin if (newthing^.kind = Afigure) then begin pageitems := newthing; goto 101; end else begin pageitems := NewItem (Afigure); pageitems^.depthnumber := depth; end; end; (* Assume that pageitems points to Afigure *) (* traverse the list *) i := pageitems; (* point to front of list for now *) p := i^.body^.things; dun := false; while ((p <> nil) and not dun) do begin if (depth = i^.depthnumber) then begin (* simple push *) dun := true; (* Note: this is the case when pushing another figure item onto an already-existing list. We push the newfigure with a depth of (fig^.depthnumber - 1) because it really is part of the higer-level figure *) end else if (depth > i^.depthnumber) then begin (* there MUST be a figure with a higher number deeper *) while ((p^.kind <> Afigure) and (p^.nextitem <> nil)) do begin p := p^.nextitem; end; if (p^.kind = Afigure) then begin i := p; p := i^.body^.things; end else begin complain (ERRREALBAD); writeln(logfile,'OOPS p^.kind isnt a figure. It must be near endoflist'); end; end; end; (* while *) (* we have the correct front of list-list, and i points to Afigure item *) newthing^.nextitem := p; i^.body^.things := newthing; 101: end; (* pushItem *) {---------------------------------------------} function Tgetfixword (k: integer) : real; var a : 0 .. 4096; f : integer; begin a := (tfm[k] * 16) + (tfm[k + 1] div 16); f := ((((tfm[k + 1] mod 16) * 256) + tfm[k + 2]) * 256) + tfm[k + 3]; if (a > 2047) then begin a := 4096 - a; if (f > 0) then begin f := TWO20 - f; a := a - 1; end; end; Tgetfixword := a + f / TWO20; end; {-----------------------------------------------------} function TgetSigned (k: integer): integer; var i: integer; begin i := tfm[k]; if (i < 128) then i := i - 256; TgetSigned := (((((i * 256) + tfm[k + 1]) * 256) + tfm[k + 2]) * 256) + tfm[k + 3]; end; {-----------------------------------------------------------} (* open a .tfm file and return the parameters in it. * Used only in conjuction with the vector and music fonts *) procedure gettfm (tfmfilnam: strng; var dessize, p1, p2, p3, p4, p5, p6, p7 : ScaledPts; var cksum : integer); label 9999; var tfmptr: integer; lf, lh, bc, ec, nw, nh, nd, ni, nl, nk, ne, np: integer; charbase, widthbase, heightbase, depthbase, italicbase, ligkernbase, kernbase, extenbase, parambase : integer; tempdesignsize : ScaledPts; begin p1 := 0; p2 := 0; p3 := 0; p4 := 0; p5 := 0; p6 := 0; p7 := 0; cksum := -1; strcopy(tfmfilnam.str, tfmname.str, tfmfilnam.len); tfmname.len := tfmfilnam.len; tfmname.str[tfmname.len + 1] := chr(32); if (not opentfmfile) then begin complain (ERRREALBAD); writestrng(tfmname,true); writeln(logfile,'---not loaded, TFM file can''t be opened!'); writestrng(tfmname,false); writeln(' cannot be opened. Aborting'); jumpout; end; tfm[0] := Tgetvaxbyte; tfm[1] := Tgetvaxbyte; lf := (tfm[0] * 256) + tfm[1]; if ((4 * lf - 1) > TFMSIZE) then begin complain (ERRREALBAD); write(logfile,'The tfm file:'); writestrng(tfmfilnam, true); writeln(logfile,' is bigger than I can handle!'); goto 9999; end; for tfmptr := 2 to (4 * lf) - 1 do begin tfm[tfmptr] := Tgetvaxbyte; end; (* for *) tfmptr := 2; lh := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; bc := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; ec := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; nw := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; nh := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; nd := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; ni := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; nl := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; nk := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; ne := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; np := (tfm[tfmptr] * 256) + tfm[tfmptr + 1]; tfmptr := tfmptr + 2; if (lf <> (6 + lh + ((ec - bc) + 1) + nw + nh + nd + ni + nl + nk + ne + np)) then begin complain (ERRREALBAD); writestrng(tfmfilnam, true); writeln(logfile,': subfile sizes don''t add up to the stated total!'); writeln(logfile,'Sorry, but I can''t go on; are you sure this is a TFM?'); goto 9999 end; if (bc > (ec + 1)) or (ec > 255) then begin complain (ERRREALBAD); writeln(logfile,'The character code range ', bc: 1, '..', ec: 1, 'is illegal!'); writeln(logfile,'Sorry, but I can''t go on; are you sure this is a TFM?'); goto 9999; end; charbase := (6 + lh) - bc; widthbase := (charbase + ec) + 1; heightbase := widthbase + nw; depthbase := heightbase + nh; italicbase := depthbase + nd; ligkernbase := italicbase + ni; kernbase := ligkernbase + nl; extenbase := kernbase + nk; parambase := (extenbase + ne) - 1; dessize := round (Tgetfixword (28) * SPPERPT); (* now in ScaledPts *) tempdesignsize := round (dessize * magfactor); cksum := TgetSigned (24); (* return the special 7 parameters for the font *) p1 := round (Tgetfixword (4 * (parambase + 1)) * tempdesignsize); p2 := round (Tgetfixword (4 * (parambase + 2)) * tempdesignsize); p3 := round (Tgetfixword (4 * (parambase + 3)) * tempdesignsize); p4 := round (Tgetfixword (4 * (parambase + 4)) * tempdesignsize); p5 := round (Tgetfixword (4 * (parambase + 5)) * tempdesignsize); p6 := round (Tgetfixword (4 * (parambase + 6)) * tempdesignsize); p7 := round (Tgetfixword (4 * (parambase + 7)) * tempdesignsize); 9999: end; {---------------------------------------------------} procedure initVnMnLtables; var i: integer; begin for i := 1 to SizVFontTable do VFontTable[i] := nil; for i := 1 to SizMFontTable do MFontTable[i] := nil; for i := 1 to SizLFontTable do LFontTable[i] := nil; VFontsDefd := 0; MFontsDefd := 0; LFontsDefd := 0; GDVIFN := 300; (* starting number for any new fonts that we define *) end; {-------------------------------------------------------} procedure fonttobedefined (kind : char; findex : integer); begin FTBDs := FTBDs + 1; (* reset this to zero after outputting 1. fontdefs 2. bop 3. contents of dvi page 4. eop *) TBD[FTBDs].which := kind; TBD[FTBDs].indx := findex; end; {-----------------------------------------------------} procedure enterfont (fontnum : integer; ck : integer; scalefact, dessiz : ScaledPts; nam : strng); var n: integer; len : integer; begin cmd1byte(FONTDEF); cmd2byte(fontnum); cmd4byte(ck); cmd4byte(scalefact); cmd4byte(dessiz); cmd1byte(USESTDAREA); len := nam.len; cmd1byte(len - 4); (* skip the length of the .tfm suffix *) for n := 1 to (nam.len - 4) do begin (* skip the .tfm suffix *) cmd1byte (xord [ nam.str[n] ]); end; end; {-----------------------------------------------------} procedure Outputfont (fontnum : integer; ck : integer; scalefact, dessiz : ScaledPts; nam : strng); var n: integer; len : integer; begin OutputByte(FONTDEF); Output2Byte(fontnum); Output4Byte(ck); Output4Byte(scalefact); Output4Byte(dessiz); OutputByte(USESTDAREA); len := nam.len; OutputByte(len - 4); for n := 1 to (nam.len - 4) do begin (* dont output the default dir prefix, nor the .tfm suffix *) OutputByte(xord [ nam.str[n] ]); end; end; {-----------------------------------------------------} procedure defineNewfonts; (* this needs to be done before first access to a font on a page later someone else will have to re-define all of them in the postamble *) label 99; var i, n : integer; f : integer; begin for i := 1 to FTBDs do begin if (TBD[i].which = 'V') then begin f := TBD[i].indx; with VFontTable[f]^ do begin if (Isdefined) then goto 99; Outputfont (DVIFontNum, Cksum, DesSize, DesSize, FontName); Isdefined := true; end; (*with *) end (* if *) else if (TBD[i].which = 'M') then begin (* music font *) f := TBD[i].indx; with MFontTable[f]^ do begin if (Isdefined) then goto 99; Outputfont (DVIFontNum, Cksum, DesSize, DesSize, FontName); Isdefined := true; end; (* with *) end (* else *) else if (TBD[i].which = 'L') then begin (* label font *) f := TBD[i].indx; with LFontTable[f]^ do begin if (Isdefined) then goto 99; Outputfont (DVIFontNum, Cksum, DesSize, DesSize, {### is this right?} FontName); Isdefined := true; end; (* with *) end else begin complain (ERRREALBAD); writeln(logfile,'Unknown type of font to be defined:"',TBD[i].which,'"'); end; (* else *) 99: end; (* for *) end; {---------------------------------------------------} function GetMusFont (stfsiz, fam : integer) : MusIndex; label 20, 99; var mustfmnam : strng; found, i : MusIndex; design, p1, p2, p3, p4, linesp, gwidth, p7 : ScaledPts; cksm, r, k : integer; begin (* see if it already exists *) found := 0; for i := 1 to MFontsDefd do (* loop through since there are few *) with MFontTable[i]^ do begin if (Staffsize = stfsiz) and (Family = fam) then begin found := i; goto 20; end; end; (* with *) 20: if (found <> 0) then begin GetMusFont := found; goto 99; end; (* Not here already--go get it *) for k := 1 to ARRLIMIT do mustfmnam.str[k] := ' '; r := 0; mustfmnam.str[r+1] := 'm'; mustfmnam.str[r+2] := 'u'; mustfmnam.str[r+3] := 's'; mustfmnam.str[r+4] := xchr[stfsiz + xord['0']]; mustfmnam.str[r+5] := xchr[fam + xord['0']]; mustfmnam.str[r+6] := '.'; mustfmnam.str[r+7] := 't'; mustfmnam.str[r+8] := 'f'; mustfmnam.str[r+9] := 'm'; mustfmnam.str[r+10] := chr(32); mustfmnam.len := 9 + r; gettfm (mustfmnam, design, p1, p2, p3, p4, linesp, gwidth, p7, cksm); MFontsDefd := MFontsDefd + 1; if (MFontsDefd > SizMFontTable) then begin complain (ERRREALBAD); writestrng(mustfmnam, true); writeln(logfile,'---not loadable. Size of Music Font table too small'); writestrng(mustfmnam,false); writeln(' cannot be loaded. Too many music fonts. Table too small.'); jumpout; end; i := MFontsDefd; new (MFontTable[i]); with MFontTable[i]^ do begin Staffsize := stfsiz; Family := fam; DesSize := design; strcopy (mustfmnam.str, FontName.str, mustfmnam.len); FontName.len := mustfmnam.len; Cksum := cksm; ghu := round (gwidth / QNOTEGHUS); gvu := round (linesp / QNOTEGVUS); DVIFontNum := GDVIFN + 1; Isdefined := false; end; GDVIFN := GDVIFN + 1; (* call someone to do the defns of cdp, cht, cwd foreach beam *) definebeams (MFontTable[i]); fonttobedefined ('M', i); GetMusFont := i; 99: end; {---------------------------------------------------} function GetVectFont (size : VThickness; vk : VectKind) : VecIndex; label 20, 99; var vectfmnam : strng; found, i : VecIndex; design, p1, p2, w0, w1, maxveclen, p6, p7 : ScaledPts; cksm, r, k : integer; begin (* see if it already exists *) found := 0; for i := 1 to VFontsDefd do with VFontTable[i]^ do begin if ((psize = size) and (vkind = vk)) then begin found := i; goto 20; end; end; (* with *) 20: if (found <> 0) then begin GetVectFont := found; goto 99; end; (* Not here--go get it *) for k := 1 to ARRLIMIT do vectfmnam.str[k] := ' '; r := 0; case (vk) of VKCirc : vectfmnam.str[r+1] := 'c'; VKVert : vectfmnam.str[r+1] := 'v'; VKHort : vectfmnam.str[r+1] := 'h'; end; (*case *) vectfmnam.str[r+2] := 'v'; vectfmnam.str[r+3] := 'e'; vectfmnam.str[r+4] := 'c'; if (size <= 9) then begin vectfmnam.str[r+5] := xchr[size + xord['0']]; vectfmnam.str[r+6] := '.'; vectfmnam.str[r+7] := 't'; vectfmnam.str[r+8] := 'f'; vectfmnam.str[r+9] := 'm'; vectfmnam.str[r+10] := chr(32); vectfmnam.len := 9 + r; end else begin vectfmnam.str[r+5] := xchr[(size div 10) + xord['0']]; vectfmnam.str[r+6] := xchr[(size - ((size div 10)*10)) + xord['0']]; vectfmnam.str[r+7] := '.'; vectfmnam.str[r+8] := 't'; vectfmnam.str[r+9] := 'f'; vectfmnam.str[r+10] := 'm'; vectfmnam.str[r+11] := chr(32); vectfmnam.len := 10 + r; end; gettfm (vectfmnam, design, p1, p2, w0, w1, maxveclen, p6, p7, cksm); VFontsDefd := VFontsDefd + 1; if (VFontsDefd > SizVFontTable) then begin complain (ERRREALBAD); writestrng(vectfmnam, true); writeln(logfile,'---not loadable. Size of Vector Font table too small'); writestrng(vectfmnam,false); writeln(' cannot be loaded. Too many vector fonts. Table too small.'); jumpout; end; i := VFontsDefd; new (VFontTable[i]); with VFontTable[i]^ do begin vkind := vk; psize := size; DesSize := design; if (vk = VKVert) then PenSize := w1 else PenSize := w0; PenSize := round (size * (MAXVECLENsp / 16.0)); MaxVectLen := maxveclen; strcopy (vectfmnam.str, FontName.str, vectfmnam.len); FontName.len := vectfmnam.len; Cksum := cksm; Isdefined := false; DVIFontNum := GDVIFN + 1; end; GDVIFN := GDVIFN + 1; definevectors (VFontTable[i]); (* someone asked for it, so they must want it, and we should fntdef it *) fonttobedefined ('V', i); GetVectFont := i; 99: end; {----------------------------------------------------------} function GetLabFont (style : integer) : integer; label 30, 99; var labtfmnam : strng; found, i : integer; design, p1, space, p3, p4, p5, p6, p7 : ScaledPts; cksm, r, k : integer; begin if (style > MAXLABELFONTS) then style := 1; found := 0; for i := 1 to LFontsDefd do with LFontTable[i]^ do begin if (internalnumber = style) then begin found := i; goto 30; end; end; 30: if (found <> 0) then begin GetLabFont := found; goto 99; end; for k := 1 to ARRLIMIT do labtfmnam.str[k] := ' '; r := 0; labtfmnam.str[r + 1] := 'c'; labtfmnam.str[r + 2] := 'm'; case style of 1: begin (* cmtt10 *) labtfmnam.str[r + 3] := 't'; labtfmnam.str[r + 4] := 't'; labtfmnam.str[r + 5] := '1'; labtfmnam.str[r + 6] := '0'; k := r + 6; end; 2: begin (* cmb10 *) labtfmnam.str[r + 3] := 'b'; labtfmnam.str[r + 4] := '1'; labtfmnam.str[r + 5] := '0'; k := r + 5; end; 3: begin (* cmsl10 *) labtfmnam.str[r + 3] := 's'; labtfmnam.str[r + 4] := 'l'; labtfmnam.str[r + 5] := '1'; labtfmnam.str[r + 6] := '0'; k := r + 6; end; 4: begin (* cmtt8 *) labtfmnam.str[r + 3] := 't'; labtfmnam.str[r + 4] := 't'; labtfmnam.str[r + 5] := '8'; k := r + 5; end; 5: begin (* cmsl8 *) labtfmnam.str[r + 3] := 's'; labtfmnam.str[r + 4] := 'l'; labtfmnam.str[r + 5] := '8'; k := r + 5; end; end; (* case *) labtfmnam.str[k + 1] := '.'; labtfmnam.str[k + 2] := 't'; labtfmnam.str[k + 3] := 'f'; labtfmnam.str[k + 4] := 'm'; labtfmnam.str[k+5] := chr(32); labtfmnam.len := k + 4; gettfm (labtfmnam, design, p1, space, p3, p4, p5, p6, p7, cksm); LFontsDefd := LFontsDefd + 1; if (LFontsDefd > SizLFontTable) then begin complain (ERRREALBAD); writestrng(labtfmnam, true); writeln(logfile,'---not loadable. Size of Label Font table too small'); writestrng(labtfmnam,false); writeln(' cannot be loaded. Too many label fonts. Table too small.'); jumpout; end; i := LFontsDefd; new (LFontTable[i]); with LFontTable[i]^ do begin strcopy (labtfmnam.str, FontName.str, labtfmnam.len); FontName.len := labtfmnam.len; Cksum := cksm; DesSize := design; internalnumber := style; spacewidth := space; DVIFontNum := GDVIFN +1; Isdefined := false; end; (* with *) GDVIFN := GDVIFN + 1; fonttobedefined ('L', i); GetLabFont := i; 99: end; {------------------------------------------------} function vectangle (dx, dy : integer) :real; begin if (dx <> 0) then vectangle := arctan (dy / (dx * 1.0)) * RADTODEG else begin if (dy > 0) then vectangle := 90.0 else vectangle := -90.0; end; end; {-----------------------------------------------------------} procedure definevectors (* var Vec: pVectFontInfRec *); var units : real; begin units := Vec^.MaxVectLen / 16.0; with Vec^.FontInfo[ 0] do begin Cht := round( 15.9688 * units); Cdp := 0; Cwd := round( 0.9981 * units); Angle := 86.4237; end; with Vec^.FontInfo[ 1] do begin Cht := round( 15.8764 * units); Cdp := 0; Cwd := round( 1.9846 * units); Angle := 82.8750; end; with Vec^.FontInfo[ 2] do begin Cht := round( 15.7260 * units); Cdp := 0; Cwd := round( 2.9486 * units); Angle := 79.3803; end; with Vec^.FontInfo[ 3] do begin Cht := round( 15.5223 * units); Cdp := 0; Cwd := round( 3.8806 * units); Angle := 75.9638; end; with Vec^.FontInfo[ 4] do begin Cht := round( 15.2717 * units); Cdp := 0; Cwd := round( 4.7724 * units); Angle := 72.6460; end; with Vec^.FontInfo[ 5] do begin Cht := round( 14.9813 * units); Cdp := 0; Cwd := round( 5.6180 * units); Angle := 69.4440; end; with Vec^.FontInfo[ 6] do begin Cht := round( 14.6585 * units); Cdp := 0; Cwd := round( 6.4131 * units); Angle := 66.3706; end; with Vec^.FontInfo[ 7] do begin Cht := round( 14.3108 * units); Cdp := 0; Cwd := round( 7.1554 * units); Angle := 63.4349; end; with Vec^.FontInfo[ 8] do begin Cht := round( 13.9452 * units); Cdp := 0; Cwd := round( 7.8442 * units); Angle := 60.6422; end; with Vec^.FontInfo[ 9] do begin Cht := round( 13.5680 * units); Cdp := 0; Cwd := round( 8.4800 * units); Angle := 57.9946; end; with Vec^.FontInfo[ 10] do begin Cht := round( 13.1847 * units); Cdp := 0; Cwd := round( 9.0645 * units); Angle := 55.4915; end; with Vec^.FontInfo[ 11] do begin Cht := round( 12.8000 * units); Cdp := 0; Cwd := round( 9.6000 * units); Angle := 53.1301; end; with Vec^.FontInfo[ 12] do begin Cht := round( 12.4178 * units); Cdp := 0; Cwd := round( 10.0895 * units); Angle := 50.9061; end; with Vec^.FontInfo[ 13] do begin Cht := round( 12.0412 * units); Cdp := 0; Cwd := round( 10.5361 * units); Angle := 48.8141; end; with Vec^.FontInfo[ 14] do begin Cht := round( 11.6726 * units); Cdp := 0; Cwd := round( 10.9431 * units); Angle := 46.8476; end; with Vec^.FontInfo[ 15] do begin Cht := round( 11.3137 * units); Cdp := 0; Cwd := round( 11.3137 * units); Angle := 45.0000; end; with Vec^.FontInfo[ 16] do begin Cht := round( 10.9431 * units); Cdp := 0; Cwd := round( 11.6726 * units); Angle := 43.1524; end; with Vec^.FontInfo[ 17] do begin Cht := round( 10.5361 * units); Cdp := 0; Cwd := round( 12.0412 * units); Angle := 41.1859; end; with Vec^.FontInfo[ 18] do begin Cht := round( 10.0895 * units); Cdp := 0; Cwd := round( 12.4178 * units); Angle := 39.0939; end; with Vec^.FontInfo[ 19] do begin Cht := round( 9.6000 * units); Cdp := 0; Cwd := round( 12.8000 * units); Angle := 36.8699; end; with Vec^.FontInfo[ 20] do begin Cht := round( 9.0645 * units); Cdp := 0; Cwd := round( 13.1847 * units); Angle := 34.5085; end; with Vec^.FontInfo[ 21] do begin Cht := round( 8.4800 * units); Cdp := 0; Cwd := round( 13.5680 * units); Angle := 32.0054; end; with Vec^.FontInfo[ 22] do begin Cht := round( 7.8442 * units); Cdp := 0; Cwd := round( 13.9452 * units); Angle := 29.3578; end; with Vec^.FontInfo[ 23] do begin Cht := round( 7.1554 * units); Cdp := 0; Cwd := round( 14.3108 * units); Angle := 26.5651; end; with Vec^.FontInfo[ 24] do begin Cht := round( 6.4131 * units); Cdp := 0; Cwd := round( 14.6585 * units); Angle := 23.6294; end; with Vec^.FontInfo[ 25] do begin Cht := round( 5.6180 * units); Cdp := 0; Cwd := round( 14.9813 * units); Angle := 20.5560; end; with Vec^.FontInfo[ 26] do begin Cht := round( 4.7724 * units); Cdp := 0; Cwd := round( 15.2717 * units); Angle := 17.3540; end; with Vec^.FontInfo[ 27] do begin Cht := round( 3.8806 * units); Cdp := 0; Cwd := round( 15.5223 * units); Angle := 14.0362; end; with Vec^.FontInfo[ 28] do begin Cht := round( 2.9486 * units); Cdp := 0; Cwd := round( 15.7260 * units); Angle := 10.6197; end; with Vec^.FontInfo[ 29] do begin Cht := round( 1.9846 * units); Cdp := 0; Cwd := round( 15.8764 * units); Angle := 7.1250; end; with Vec^.FontInfo[ 30] do begin Cht := round( 0.9981 * units); Cdp := 0; Cwd := round( 15.9688 * units); Angle := 3.5763; end; with Vec^.FontInfo[ 31] do begin Cht := 0; Cdp := 0; Cwd := round( 16.0000 * units); Angle := 0.0000; end; with Vec^.FontInfo[ 32] do begin Cdp := round( 0.9981 * units); Cht := 0; Cwd := round( 15.9688 * units); Angle := -3.5763; end; with Vec^.FontInfo[ 33] do begin Cdp := round( 1.9846 * units); Cht := 0; Cwd := round( 15.8764 * units); Angle := -7.1250; end; with Vec^.FontInfo[ 34] do begin Cdp := round( 2.9486 * units); Cht := 0; Cwd := round( 15.7260 * units); Angle := -10.6197; end; with Vec^.FontInfo[ 35] do begin Cdp := round( 3.8806 * units); Cht := 0; Cwd := round( 15.5223 * units); Angle := -14.0362; end; with Vec^.FontInfo[ 36] do begin Cdp := round( 4.7724 * units); Cht := 0; Cwd := round( 15.2717 * units); Angle := -17.3540; end; with Vec^.FontInfo[ 37] do begin Cdp := round( 5.6180 * units); Cht := 0; Cwd := round( 14.9813 * units); Angle := -20.5560; end; with Vec^.FontInfo[ 38] do begin Cdp := round( 6.4131 * units); Cht := 0; Cwd := round( 14.6585 * units); Angle := -23.6294; end; with Vec^.FontInfo[ 39] do begin Cdp := round( 7.1554 * units); Cht := 0; Cwd := round( 14.3108 * units); Angle := -26.5651; end; with Vec^.FontInfo[ 40] do begin Cdp := round( 7.8442 * units); Cht := 0; Cwd := round( 13.9452 * units); Angle := -29.3578; end; with Vec^.FontInfo[ 41] do begin Cdp := round( 8.4800 * units); Cht := 0; Cwd := round( 13.5680 * units); Angle := -32.0054; end; with Vec^.FontInfo[ 42] do begin Cdp := round( 9.0645 * units); Cht := 0; Cwd := round( 13.1847 * units); Angle := -34.5085; end; with Vec^.FontInfo[ 43] do begin Cdp := round( 9.6000 * units); Cht := 0; Cwd := round( 12.8000 * units); Angle := -36.8699; end; with Vec^.FontInfo[ 44] do begin Cdp := round( 10.0895 * units); Cht := 0; Cwd := round( 12.4178 * units); Angle := -39.0939; end; with Vec^.FontInfo[ 45] do begin Cdp := round( 10.5361 * units); Cht := 0; Cwd := round( 12.0412 * units); Angle := -41.1859; end; with Vec^.FontInfo[ 46] do begin Cdp := round( 10.9431 * units); Cht := 0; Cwd := round( 11.6726 * units); Angle := -43.1524; end; with Vec^.FontInfo[ 47] do begin Cdp := round( 11.3137 * units); Cht := 0; Cwd := round( 11.3137 * units); Angle := -45.0000; end; with Vec^.FontInfo[ 48] do begin Cdp := round ( 11.6726 * units); Cht := 0; Cwd := round( 10.9431 * units); Angle := -46.8476; end; with Vec^.FontInfo[ 49] do begin Cdp := round ( 12.0412 * units); Cht := 0; Cwd := round( 10.5361 * units); Angle := -48.8141; end; with Vec^.FontInfo[ 50] do begin Cdp := round ( 12.4178 * units); Cht := 0; Cwd := round( 10.0895 * units); Angle := -50.9061; end; with Vec^.FontInfo[ 51] do begin Cdp := round ( 12.8000 * units); Cht := 0; Cwd := round( 9.6000 * units); Angle := -53.1301; end; with Vec^.FontInfo[ 52] do begin Cdp := round ( 13.1847 * units); Cht := 0; Cwd := round( 9.0645 * units); Angle := -55.4915; end; with Vec^.FontInfo[ 53] do begin Cdp := round ( 13.5680 * units); Cht := 0; Cwd := round( 8.4800 * units); Angle := -57.9946; end; with Vec^.FontInfo[ 54] do begin Cdp := round ( 13.9452 * units); Cht := 0; Cwd := round( 7.8442 * units); Angle := -60.6422; end; with Vec^.FontInfo[ 55] do begin Cdp := round ( 14.3108 * units); Cht := 0; Cwd := round( 7.1554 * units); Angle := -63.4349; end; with Vec^.FontInfo[ 56] do begin Cdp := round ( 14.6585 * units); Cht := 0; Cwd := round( 6.4131 * units); Angle := -66.3706; end; with Vec^.FontInfo[ 57] do begin Cdp := round ( 14.9813 * units); Cht := 0; Cwd := round( 5.6180 * units); Angle := -69.4440; end; with Vec^.FontInfo[ 58] do begin Cdp := round ( 15.2717 * units); Cht := 0; Cwd := round( 4.7724 * units); Angle := -72.6460; end; with Vec^.FontInfo[ 59] do begin Cdp := round ( 15.5223 * units); Cht := 0; Cwd := round( 3.8806 * units); Angle := -75.9638; end; with Vec^.FontInfo[ 60] do begin Cdp := round ( 15.7260 * units); Cht := 0; Cwd := round( 2.9486 * units); Angle := -79.3803; end; with Vec^.FontInfo[ 61] do begin Cdp := round ( 15.8764 * units); Cht := 0; Cwd := round( 1.9846 * units); Angle := -82.8750; end; with Vec^.FontInfo[ 62] do begin Cdp := round ( 15.9688 * units); Cht := 0; Cwd := round( 0.9981 * units); Angle := -86.4237; end; with Vec^.FontInfo[ 63] do begin Cht := round( 8.0000 * units); Cdp := 0; Cwd := 0; Angle := 90.0000; end; with Vec^.FontInfo[ 64] do begin Cht := round( 7.9382 * units); Cdp := 0; Cwd := round( 0.9923 * units); Angle := 82.8750; end; with Vec^.FontInfo[ 65] do begin Cht := round( 7.7611 * units); Cdp := 0; Cwd := round( 1.9403 * units); Angle := 75.9638; end; with Vec^.FontInfo[ 66] do begin Cht := round( 7.4906 * units); Cdp := 0; Cwd := round( 2.8090 * units); Angle := 69.4440; end; with Vec^.FontInfo[ 67] do begin Cht := round( 7.1554 * units); Cdp := 0; Cwd := round( 3.5777 * units); Angle := 63.4349; end; with Vec^.FontInfo[ 68] do begin Cht := round( 6.7840 * units); Cdp := 0; Cwd := round( 4.2400 * units); Angle := 57.9946; end; with Vec^.FontInfo[ 69] do begin Cht := round( 6.4000 * units); Cdp := 0; Cwd := round( 4.8000 * units); Angle := 53.1301; end; with Vec^.FontInfo[ 70] do begin Cht := round( 6.0206 * units); Cdp := 0; Cwd := round( 5.2680 * units); Angle := 48.8141; end; with Vec^.FontInfo[ 71] do begin Cht := round( 5.6569 * units); Cdp := 0; Cwd := round( 5.6569 * units); Angle := 45.0000; end; with Vec^.FontInfo[ 72] do begin Cht := round( 5.2680 * units); Cdp := 0; Cwd := round( 6.0206 * units); Angle := 41.1859; end; with Vec^.FontInfo[ 73] do begin Cht := round( 4.8000 * units); Cdp := 0; Cwd := round( 6.4000 * units); Angle := 36.8699; end; with Vec^.FontInfo[ 74] do begin Cht := round( 4.2400 * units); Cdp := 0; Cwd := round( 6.7840 * units); Angle := 32.0054; end; with Vec^.FontInfo[ 75] do begin Cht := round( 3.5777 * units); Cdp := 0; Cwd := round( 7.1554 * units); Angle := 26.5651; end; with Vec^.FontInfo[ 76] do begin Cht := round( 2.8090 * units); Cdp := 0; Cwd := round( 7.4906 * units); Angle := 20.5560; end; with Vec^.FontInfo[ 77] do begin Cht := round( 1.9403 * units); Cdp := 0; Cwd := round( 7.7611 * units); Angle := 14.0362; end; with Vec^.FontInfo[ 78] do begin Cht := round( 0.9923 * units); Cdp := 0; Cwd := round( 7.9382 * units); Angle := 7.1250; end; with Vec^.FontInfo[ 79] do begin Cht := 0; Cdp := 0; Cwd := round( 8.0000 * units); Angle := 0.0000; end; with Vec^.FontInfo[ 80] do begin Cdp := round( 0.9923 * units); Cht := 0; Cwd := round( 7.9382 * units); Angle := -7.1250; end; with Vec^.FontInfo[ 81] do begin Cdp := round( 1.9403 * units); Cht := 0; Cwd := round( 7.7611 * units); Angle := -14.0362; end; with Vec^.FontInfo[ 82] do begin Cdp := round( 2.8090 * units); Cht := 0; Cwd := round( 7.4906 * units); Angle := -20.5560; end; with Vec^.FontInfo[ 83] do begin Cdp := round( 3.5777 * units); Cht := 0; Cwd := round( 7.1554 * units); Angle := -26.5651; end; with Vec^.FontInfo[ 84] do begin Cdp := round( 4.2400 * units); Cht := 0; Cwd := round( 6.7840 * units); Angle := -32.0054; end; with Vec^.FontInfo[ 85] do begin Cdp := round( 4.8000 * units); Cht := 0; Cwd := round( 6.4000 * units); Angle := -36.8699; end; with Vec^.FontInfo[ 86] do begin Cdp := round( 5.2680 * units); Cht := 0; Cwd := round( 6.0206 * units); Angle := -41.1859; end; with Vec^.FontInfo[ 87] do begin Cdp := round( 5.6569 * units); Cht := 0; Cwd := round( 5.6569 * units); Angle := -45.0000; end; with Vec^.FontInfo[ 88] do begin Cdp := round ( 6.0206 * units); Cht := 0; Cwd := round( 5.2680 * units); Angle := -48.8141; end; with Vec^.FontInfo[ 89] do begin Cdp := round ( 6.4000 * units); Cht := 0; Cwd := round( 4.8000 * units); Angle := -53.1301; end; with Vec^.FontInfo[ 90] do begin Cdp := round ( 6.7840 * units); Cht := 0; Cwd := round( 4.2400 * units); Angle := -57.9946; end; with Vec^.FontInfo[ 91] do begin Cdp := round ( 7.1554 * units); Cht := 0; Cwd := round( 3.5777 * units); Angle := -63.4349; end; with Vec^.FontInfo[ 92] do begin Cdp := round ( 7.4906 * units); Cht := 0; Cwd := round( 2.8090 * units); Angle := -69.4440; end; with Vec^.FontInfo[ 93] do begin Cdp := round ( 7.7611 * units); Cht := 0; Cwd := round( 1.9403 * units); Angle := -75.9638; end; with Vec^.FontInfo[ 94] do begin Cdp := round ( 7.9382 * units); Cht := 0; Cwd := round( 0.9923 * units); Angle := -82.8750; end; with Vec^.FontInfo[ 95] do begin Cdp := round ( 8.0000 * units); Cht := 0; Cwd := 0; Angle := -90.0000; end; with Vec^.FontInfo[ 96] do begin Cht := round( 4.0000 * units); Cdp := 0; Cwd := 0; Angle := 90.0000; end; with Vec^.FontInfo[ 97] do begin Cht := round( 3.8806 * units); Cdp := 0; Cwd := round( 0.9701 * units); Angle := 75.9638; end; with Vec^.FontInfo[ 98] do begin Cht := round( 3.5777 * units); Cdp := 0; Cwd := round( 1.7889 * units); Angle := 63.4349; end; with Vec^.FontInfo[ 99] do begin Cht := round( 3.2000 * units); Cdp := 0; Cwd := round( 2.4000 * units); Angle := 53.1301; end; with Vec^.FontInfo[100] do begin Cht := round( 2.8284 * units); Cdp := 0; Cwd := round( 2.8284 * units); Angle := 45.0000; end; with Vec^.FontInfo[101] do begin Cht := round( 2.4000 * units); Cdp := 0; Cwd := round( 3.2000 * units); Angle := 36.8699; end; with Vec^.FontInfo[102] do begin Cht := round( 1.7889 * units); Cdp := 0; Cwd := round( 3.5777 * units); Angle := 26.5651; end; with Vec^.FontInfo[103] do begin Cht := round( 0.9701 * units); Cdp := 0; Cwd := round( 3.8806 * units); Angle := 14.0362; end; with Vec^.FontInfo[104] do begin Cht := 0; Cdp := 0; Cwd := round( 4.0000 * units); Angle := 0.0000; end; with Vec^.FontInfo[105] do begin Cdp := round( 0.9701 * units); Cht := 0; Cwd := round( 3.8806 * units); Angle := -14.0362; end; with Vec^.FontInfo[106] do begin Cdp := round( 1.7889 * units); Cht := 0; Cwd := round( 3.5777 * units); Angle := -26.5651; end; with Vec^.FontInfo[107] do begin Cdp := round( 2.4000 * units); Cht := 0; Cwd := round( 3.2000 * units); Angle := -36.8699; end; with Vec^.FontInfo[108] do begin Cdp := round( 2.8284 * units); Cht := 0; Cwd := round( 2.8284 * units); Angle := -45.0000; end; with Vec^.FontInfo[109] do begin Cdp := round ( 3.2000 * units); Cht := 0; Cwd := round( 2.4000 * units); Angle := -53.1301; end; with Vec^.FontInfo[110] do begin Cdp := round ( 3.5777 * units); Cht := 0; Cwd := round( 1.7889 * units); Angle := -63.4349; end; with Vec^.FontInfo[111] do begin Cdp := round ( 3.8806 * units); Cht := 0; Cwd := round( 0.9701 * units); Angle := -75.9638; end; with Vec^.FontInfo[112] do begin Cdp := round ( 4.0000 * units); Cht := 0; Cwd := 0; Angle := -90.0000; end; with Vec^.FontInfo[113] do begin Cht := round( 2.0000 * units); Cdp := 0; Cwd := 0; Angle := 90.0000; end; with Vec^.FontInfo[114] do begin Cht := round( 1.7889 * units); Cdp := 0; Cwd := round( 0.8944 * units); Angle := 63.4349; end; with Vec^.FontInfo[115] do begin Cht := round( 1.4142 * units); Cdp := 0; Cwd := round( 1.4142 * units); Angle := 45.0000; end; with Vec^.FontInfo[116] do begin Cht := round( 0.8944 * units); Cdp := 0; Cwd := round( 1.7889 * units); Angle := 26.5651; end; with Vec^.FontInfo[117] do begin Cht := 0; Cdp := 0; Cwd := round( 2.0000 * units); Angle := 0.0000; end; with Vec^.FontInfo[118] do begin Cdp := round( 0.8944 * units); Cht := 0; Cwd := round( 1.7889 * units); Angle := -26.5651; end; with Vec^.FontInfo[119] do begin Cdp := round( 1.4142 * units); Cht := 0; Cwd := round( 1.4142 * units); Angle := -45.0000; end; with Vec^.FontInfo[120] do begin Cdp := round ( 1.7889 * units); Cht := 0; Cwd := round( 0.8944 * units); Angle := -63.4349; end; with Vec^.FontInfo[121] do begin Cdp := round ( 2.0000 * units); Cht := 0; Cwd := 0; Angle := -90.0000; end; with Vec^.FontInfo[122] do begin Cht := round( 1.0000 * units); Cdp := 0; Cwd := 0; Angle := 90.0000; end; with Vec^.FontInfo[123] do begin Cht := round( 0.7071 * units); Cdp := 0; Cwd := round( 0.7071 * units); Angle := 45.0000; end; with Vec^.FontInfo[124] do begin Cht := 0; Cdp := 0; Cwd := round( 1.0000 * units); Angle := 0.0000; end; with Vec^.FontInfo[125] do begin Cdp := round( 0.7071 * units); Cht := 0; Cwd := round( 0.7071 * units); Angle := -45.0000; end; with Vec^.FontInfo[126] do begin Cdp := round ( 1.0000 * units); Cht := 0; Cwd := 0; Angle := -90.0000; end; with Vec^.FontInfo[127] do begin Cht := 0; Cdp := 0; Cwd := 0; Angle := -90.0000; end; end; (* define vectors *) {-------------------------------------------------} (* If, for some reason, you do not want to deal with music capabilities, replace the body of this procedure with just a begin end; pair and also the TylBeam proc. *) procedure definebeams (* var M : pMusFontInfRec *); var i : integer; begin end; {----------------------------------------------------------} (* use pre-calculated coordinates of a circle that has a * given unit-radius. Scale those points to fit the desired radius *) procedure defineCircleCpts (rad : ScaledPts; centx, centy : ScaledPts; var CircleCpt : ControlPoints; var numpts : integer); const UnitRadius = 16777216; (* TWO24 scaledpts *) var ratio : real; begin if (rad = 0) then begin complain (ERRBAD); writeln(logfile,'Error in fig#',pgfigurenum:0,' on page ',currpagenum:0); writeln(logfile,'Zero length radius for circle! Setting to 1 sp'); rad := 1; end; ratio := float(rad) / float(UnitRadius); numpts := 16; CircleCpt[1,1] := round (ratio * 16777216.00000) + centx; CircleCpt[1,2] := 0 + centy; {round (ratio * 0.00000)} CircleCpt[2,1] := round (ratio * 15500126.47492) + centx; CircleCpt[2,2] := round (ratio * 6420362.60441) + centy; CircleCpt[3,1] := round (ratio * 11863283.20303) + centx; CircleCpt[3,2] := round (ratio * 11863283.20303) + centy; CircleCpt[4,1] := round (ratio * 6420362.60441) + centx; CircleCpt[4,2] := round (ratio * 15500126.47492) + centy; CircleCpt[5,1] := 0 + centx; {round (ratio * -0.00000) } CircleCpt[5,2] := round (ratio * 16777216.00000) + centy; CircleCpt[6,1] := round (ratio * -6420362.60441) + centx; CircleCpt[6,2] := round (ratio * 15500126.47492) + centy; CircleCpt[7,1] := round (ratio * -11863283.20303) + centx; CircleCpt[7,2] := round (ratio * 11863283.20303) + centy; CircleCpt[8,1] := round (ratio * -15500126.47492) + centx; CircleCpt[8,2] := round (ratio * 6420362.60441) + centy; CircleCpt[9,1] := round (ratio * -16777216.00000) + centx; CircleCpt[9,2] := 0 + centy; {round (ratio * -0.00000)} CircleCpt[10,1] := round (ratio * -15500126.47492) + centx; CircleCpt[10,2] := round (ratio * -6420362.60441) + centy; CircleCpt[11,1] := round (ratio * -11863283.20303) + centx; CircleCpt[11,2] := round (ratio * -11863283.20303) + centy; CircleCpt[12,1] := round (ratio * -6420362.60441) + centx; CircleCpt[12,2] := round (ratio * -15500126.47492) + centy; CircleCpt[13,1] := 0 + centx; {round (ratio * 0.00000) } CircleCpt[13,2] := round (ratio * -16777216.00000) + centy; CircleCpt[14,1] := round (ratio * 6420362.60441) + centx; CircleCpt[14,2] := round (ratio * -15500126.47492) + centy; CircleCpt[15,1] := round (ratio * 11863283.20303) + centx; CircleCpt[15,2] := round (ratio * -11863283.20303) + centy; CircleCpt[16,1] := round (ratio * 15500126.47492) + centx; CircleCpt[16,2] := round (ratio * -6420362.60441) + centy; (* create the pre-list phantom *) CircleCpt[0,1] := CircleCpt[16,1]; CircleCpt[0,2] := CircleCpt[16,2]; end; {---------------------------------------------------------------} (* compute control points for an arc going from startangle to * stopangle, centered at (centx, centy) *) procedure definearcpts (rad : ScaledPts; centx, centy : ScaledPts; startang, stopang : integer; var cpts : ControlPoints; var nknots : integer); var n : integer; a, b, curr, delta: real; i : integer; begin a := startang * DEGTORAD; b := stopang * DEGTORAD; n := 16; if (a > b) then begin a := a - (2 * PI); end; delta := abs(b - a) / n; if (a = b) then begin complain (ERRNOTBAD); writeln(logfile,'Error in compute arc points:: should be a circle'); end; curr := a; i := 1; while ((curr <= b)) do begin (* make arc about (centx,centy) *) cpts[i,1] := round (rad * cos (curr)) + centx; cpts[i,2] := round (rad * sin (curr)) + centy; i := i + 1; curr := curr + delta; end; (* while *) (* go one point beyond -- * around the arc so that we can have good smoothness * for this phantom point *) cpts[i,1] := round (rad * cos (b + delta)) + centx; cpts[i,2] := round (rad * sin (b + delta)) + centy; (* and one phantom point before the list *) cpts[0,1] := round (rad * cos (a - delta)) + centx; cpts[0,2] := round (rad * sin (a - delta)) + centy; nknots := i-1; end; (* &&Module spline.p *) (* Procedures below may make free use of the global variables arrayXY [list of control points] pointmatrix [list of spline segments] knot [list of spline knots] catrommtx [matrix for Catmull-Rom splines] bsplmtx [matrix for B-splines] lastPoint, intervals *) {-----------------------------------------------------} function max (a, b: integer):integer; begin if (a > b) then max := a else max := b; end; {-----------------------------------------------------} function min (a, b: integer):integer; begin if (a < b) then min := a else min := b; end; {---------------------------------------------------------------------} (* initialize the Catmull-Rom basis matrix *) procedure initcrmatrix; begin catrommtx[1,1] := -0.5; catrommtx[1,2] := 1.5; catrommtx[1,3] := -1.5; catrommtx[1,4] := 0.5; catrommtx[2,1] := 1.0; catrommtx[2,2] := -2.5; catrommtx[2,3] := 2.0; catrommtx[2,4] := -0.5; catrommtx[3,1] := -0.5; catrommtx[3,2] := 0.0; catrommtx[3,3] := 0.5; catrommtx[3,4] := 0.0; catrommtx[4,1] := 0.0; catrommtx[4,2] := 1.0; catrommtx[4,3] := 0.0; catrommtx[4,4] := 0.0; end; {-----------------------------------------------------} procedure initbsplmatrix; begin bsplmtx[1,1] := -1.0/6.0; bsplmtx[1,2] := 0.5; bsplmtx[1,3] := -0.5; bsplmtx[1,4] := 1.0/6.0; bsplmtx[2,1] := 0.5; bsplmtx[2,2] := -1.0; bsplmtx[2,3] := 0.5; bsplmtx[2,4] := 0.0; bsplmtx[3,1] := -0.5; bsplmtx[3,2] := 0.0; bsplmtx[3,3] := 0.5; bsplmtx[3,4] := 0.0; bsplmtx[4,1] := 1.0/6.0; bsplmtx[4,2] := 2.0/3.0; bsplmtx[4,3] := 1.0/6.0; bsplmtx[4,4] := 0.0; end; {--------------------------------------------------------} (* init the Cardinal Spline Matrix *) procedure initcardmatrix; begin cardmtx[1,1] := -1.0; cardmtx[1,2] := 1.0; cardmtx[1,3] := -1.0; cardmtx[1,4] := 1.0; cardmtx[2,1] := 2.0; cardmtx[2,2] := -2.0; cardmtx[2,3] := 1.0; cardmtx[2,4] := -1.0; cardmtx[3,1] := -1.0; cardmtx[3,2] := 0.0; cardmtx[3,3] := 1.0; cardmtx[3,4] := 0.0; cardmtx[4,1] := 0.0; cardmtx[4,2] := 1.0; cardmtx[4,3] := 0.0; cardmtx[4,4] := 0.0; end; {--------------------------------------------------------} procedure initallspline; begin initcrmatrix; initbsplmatrix; initcardmatrix; end; {-----------------------------------------------------} procedure matXvector (var m: Fourby4Matrix; (* IN *) var v: Oneby4Vector; (* IN *) var result: Oneby4Vector); (* OUT *) var t: Oneby4Vector; begin t[1] := v[1]*m[1,1] + v[2]*m[1,2] + v[3]*m[1,3] + v[4]*m[1,4]; t[2] := v[1]*m[2,1] + v[2]*m[2,2] + v[3]*m[2,3] + v[4]*m[2,4]; t[3] := v[1]*m[3,1] + v[2]*m[3,2] + v[3]*m[3,3] + v[4]*m[3,4]; t[4] := v[1]*m[4,1] + v[2]*m[4,2] + v[3]*m[4,3] + v[4]*m[4,4]; result[1] := t[1]; result[2] := t[2]; result[3] := t[3]; result[4] := t[4]; end; {-----------------------------------------------------} (* actually the dot-product *) function vecXvec (var v1, v2: Oneby4Vector) : real; begin vecXvec := v1[1]*v2[1] + v1[2]*v2[2] + v1[3]*v2[3] + v1[4]*v2[4]; end; {------------------------------------------------------} (* basXctl is the pre-computed BasisMatrix times the control-point vector *) function splinePosition (var basXctl : Oneby4Vector; (* IN *) t : real ) : real; var tvect : Oneby4Vector; { vector of t values for spline matrix} begin tvect[4] := 1.0; tvect[3] := t; tvect[2] := t * t; if (tvect[2] <= MINREAL) then begin (* avoid underflow problems *) tvect[2] := 0.0; end; tvect[1] := t * tvect[2]; (* t^3 *) splinePosition := vecXvec (tvect, basXctl); end; {-------------------------------------------------} function TwoToThe (n : integer) : integer; label 78; var i : integer; tmp : integer; begin tmp := 1; if (n <= 0) then goto 78; if (n < 6) then begin case n of 1 : tmp := 2; 2 : tmp := 4; 3 : tmp := 8; 4 : tmp := 16; 5 : tmp := 32; end; (* case *) end (* if *) else begin tmp := 32; for i := 6 to n do tmp := tmp * 2; end; 78: TwoToThe := tmp; end; {------------------------------------------------------} function distance (x0, y0, x1, y1 : real) : real; var res : real; begin res := sqrt ( (x1 - x0)*(x1 - x0) + (y1 - y0)*(y1 - y0)); distance := res; end; {------------------------------------------------------} (* compute the number of subdivisions for this span. We do this by a quadrature method and a simple linear-distance metric. This is not optimal in the number of subdivisions actually required, but is computationally efficient and accurate to the nearest power of 2 . *) function numsubdivisions (var XtimesBas, YtimesBas : Oneby4Vector; resolution : ScaledPts): integer; var n : integer; d : integer; t : real; x0, y0, xt, yt : real; begin x0 := splinePosition (XtimesBas, 0.0); y0 := splinePosition (YtimesBas, 0.0); t := 1.0; n := 0; xt := splinePosition (XtimesBas, t); yt := splinePosition (YtimesBas, t); while ((round (distance (x0, y0, xt, yt)) > resolution) or (n < 1)) do begin t := t / 2.0; (* perform the quadrature *) n := n + 1; xt := splinePosition (XtimesBas, t); yt := splinePosition (YtimesBas, t); end; (* while *) numsubdivisions := TwoToThe (n); end; {------------------------------------------------------------------------} (* compute new control vertices such that the resulting spline * will interpolate through the old control points. * This will work as long as the actual arc length * between consecutive nodes does not vary from span to span. * The method is noted in Wu and Abel's CACM 20(10) Oct 77 paper * but the actual working method is from * Barsky and Greenberg's paper in * CG&IP 14(3) Nov 1980 pp.203-226 *) procedure invertsplvertices (numpts : integer; isclosed : boolean; var xys : ControlPoints); (* INOUT *) var i : integer; beta, Xrprime, Yrprime : array[0..MAXCTLPTS] of real; tempxys : ControlPoints; begin (* compute the values of beta *) beta[1] := 0.25; for i := 2 to numpts + 1 do beta[i] := 1.0 / (4.0 - beta[i - 1]); (* and the r primes from the original vertices *) Xrprime[1] := beta[1] * xys[1,1] * 5.0; Yrprime[1] := beta[1] * xys[1,2] * 5.0; for i := 2 to numpts -1 do begin Xrprime[i] := beta[i] * (6.0 * xys[i,1] - Xrprime[i - 1]); Yrprime[i] := beta[i] * (6.0 * xys[i,2] - Yrprime[i - 1]); end; (* for *) Xrprime[numpts] := beta[numpts] * (5.0 * xys[numpts,1] - Xrprime[numpts - 1]); Yrprime[numpts] := beta[numpts] * (5.0 * xys[numpts,2] - Yrprime[numpts - 1]); (* Now perform the back-substitution from the bottom up *) tempxys[numpts,1] := round (Xrprime[numpts]); tempxys[numpts,2] := round (Yrprime[numpts]); for i := numpts - 1 downto 1 do begin tempxys[i,1] := round (Xrprime[i] - beta[i] * tempxys[i + 1, 1]); tempxys[i,2] := round (Yrprime[i] - beta[i] * tempxys[i + 1, 2]); end; if (isclosed) then begin (* at this point, we've probably been through one control-point * adjustment, so let's not muck it up *) tempxys[numpts+1,1] := tempxys[1,1]; tempxys[numpts+1,2] := tempxys[1,2]; tempxys[numpts+2,1] := tempxys[2,1]; tempxys[numpts+2,2] := tempxys[2,2]; tempxys[0,1] := tempxys[numpts,1]; tempxys[0,2] := tempxys[numpts,2]; (* copy them back *) for i := 0 to (numpts+2) do begin xys[i,1] := tempxys[i,1]; xys[i,2] := tempxys[i,2]; end; end (* closed *) else begin (* copy back *) for i := 2 to numpts -1 do begin xys[i,1] := tempxys[i,1]; xys[i,2] := tempxys[i,2]; end; end; (* open*) end; {-----------------------------------------------------} (* adjust the list of control points so that we can use * it for B-spline interpolation. * Add any "phantom" vertices necessary so that the end * conditions will be correct for interpolation *) procedure Bctlptadjust (isclosed : boolean; isarc : boolean; var n: integer; (* INOUT *) var xys: ControlPoints; (* INOUT *) var thx: ThickAryType); (* INOUT *) var j : integer; tmp : ControlPoints; tmpthx : ThickAryType; begin (* ctlpt adjust*) if (isclosed) then begin (* here, we have to supply the last 'real' point for the user, and add three phantoms-- one before, and two after *) if (n = 2) then begin complain (ERRBAD); writeln(logfile,'A closed spline requires more than 2 control points '); writeln(logfile,'making a temporary fix in order to continue...'); xys[3,1] := xys[1,1]; xys[3,2] := xys[1,2]; end; for j := 1 to (n) do begin tmp[j, 1] := xys[j, 1]; tmp[j, 2] := xys[j, 2]; tmpthx[j] := thx[j]; end; (* Now take care of the 'phantom' vertices *) tmp[n+1, 1] := xys[1, 1]; tmp[n+1, 2] := xys[1, 2]; tmpthx[n+1] := thx[1]; tmp[n+2, 1] := xys[2, 1]; tmp[n+2, 2] := xys[2, 2]; tmpthx[n+2] := thx[2]; tmp[n+3, 1] := xys[3, 1]; tmp[n+3, 2] := xys[3, 2]; tmpthx[n+3] := thx[3]; if (not isarc) then begin tmp[0,1] := xys[n, 1]; (* wrap around to the real last point *) tmp[0,2] := xys[n, 2]; tmpthx[0] := thx[n]; end else begin tmp[0,1] := xys[0,1]; tmp[0,2] := xys[0,2]; tmpthx[0] := thx[0]; end; n := n + 1; (* we supplied the 'last' point for the user *) for j := 0 to n+2 do begin xys[j,1] := tmp[j,1]; xys[j,2] := tmp[j,2]; thx[j] := tmpthx[j]; end; (* for *) end (* if closed *) else begin (* OPEN SPLINE *) if (not isarc) then begin tmp[0,1] := 2 * xys[1, 1] - xys[2,1]; tmp[0,2] := 2 * xys[1, 2] - xys[2,2]; end else begin tmp[0,1] := xys[0,1]; tmp[0,2] := xys[0,2]; end; tmpthx[0] := thx[1]; for j := 1 to (n) do begin tmp[j, 1] := xys[j, 1]; tmp[j, 2] := xys[j, 2]; tmpthx[j] := thx[j]; end; tmp[n+1, 1] := 2 * xys[n, 1] - xys[n-1,1]; tmp[n+1, 2] := 2 * xys[n, 2] - xys[n-1,2]; tmpthx[n+1] := thx[n]; tmp[n+2, 1] := tmp[n+1, 1]; tmp[n+2, 2] := tmp[n+1, 2]; tmpthx[n+2] := thx[n]; for j := 0 to n+2 do begin xys[j,1] := tmp[j,1]; xys[j,2] := tmp[j,2]; thx[j] := tmpthx[j]; end; (* for *) end; (* if open *) end; {-----------------------------------------------------} (* adjust the list of control points so that we can use * it for simple Catmull-Rom spline interpolation. * Add any "phantom" vertices necessary so that the end * conditions will be correct for interpolation *) procedure CRctlptadjust (isclosed : boolean; isarc : boolean; var n: integer; (* INOUT *) var xys: ControlPoints; (* INOUT *) var thx: ThickAryType); (* INOUT *) var j : integer; tmp : ControlPoints; tmpthx : ThickAryType; begin (* ctlpt adjust*) if (isclosed) then begin (* here, we have to supply the last 'real' point for the user, and add three phantoms-- one before, and two after *) if (n = 2) then begin complain (ERRBAD); writeln(logfile,'A closed spline requires more than 2 control points '); writeln(logfile,'making a temporary fix in order to continue...'); xys[3,1] := xys[1,1]; xys[3,2] := xys[1,2]; end; for j := 1 to (n) do begin tmp[j, 1] := xys[j, 1]; tmp[j, 2] := xys[j, 2]; tmpthx[j] := thx[j]; end; (* the phantom vertices *) tmp[n+1, 1] := xys[1, 1]; tmp[n+1, 2] := xys[1, 2]; tmpthx[n+1] := thx[1]; tmp[n+2, 1] := xys[2, 1]; tmp[n+2, 2] := xys[2, 2]; tmpthx[n+2] := thx[2]; tmp[n+3, 1] := xys[3, 1]; tmp[n+3, 2] := xys[3, 2]; tmpthx[n+3] := thx[3]; if (not isarc) then begin tmp[0,1] := xys[n, 1]; (* wrap around to the real last point *) tmp[0,2] := xys[n, 2]; tmpthx[0] := thx[n]; end else begin tmp[0,1] := xys[0,1]; tmp[0,2] := xys[0,2]; tmpthx[0] := thx[0]; end; n := n + 1; (* we supplied the 'last' point for the user *) for j := 0 to n+2 do begin xys[j,1] := tmp[j,1]; xys[j,2] := tmp[j,2]; thx[j] := tmpthx[j]; end; (* for *) end (* if closed *) else begin (* OPEN SPLINE *) if (not isarc) then begin tmp[0,1] := xys[1, 1]; (* double the first point *) tmp[0,2] := xys[1, 2]; end else begin tmp[0,1] := xys[0,1]; tmp[0,2] := xys[0,2]; end; tmpthx[0] := thx[1]; for j := 1 to (n) do begin tmp[j, 1] := xys[j, 1]; tmp[j, 2] := xys[j, 2]; tmpthx[j] := thx[j]; end; tmp[n+1, 1] := xys[n, 1]; (* and triple the last *) tmp[n+1, 2] := xys[n, 2]; tmpthx[n+1] := thx[n]; tmp[n+2, 1] := xys[n, 1]; tmp[n+2, 2] := xys[n, 2]; tmpthx[n+2] := thx[n]; for j := 0 to n+2 do begin xys[j,1] := tmp[j,1]; xys[j,2] := tmp[j,2]; thx[j] := tmpthx[j]; end; (* for *) end; (* if open *) end; (* ctlpt adjust *) {----------------------------------------------------------} procedure interpsplines (splinetype: SplineKind; isclosed: boolean; isanArc: boolean; linepatt : LineStyle; var basismatrix : Fourby4Matrix; (* IN *) numctls: integer; var arrayXY: ControlPoints; (* IN *) var pointmatrix: SplineSegments; (* OUT *) varythicks: boolean; var thickmatrix: ThickAryType; (* IN *) var TTmatrix: ThickAryType); (* OUT *) label 32; var xctl, yctl, { vectors of x, y posits of control points} wctl : Oneby4Vector; {vector of thicknesses at each ctl pt} t, incr: real; Pi: integer; { P sub i } i, currpt : integer; theresolution : ScaledPts; begin (* interp splines*) if ((not isclosed) and (isanArc)) then numctls := numctls + 1; (* lie a little *) case (splinetype) of BSPL: Bctlptadjust (isclosed, isanArc, numctls, arrayXY, thickmatrix); CARD, CATROM: CRctlptadjust (isclosed, isanArc, numctls, arrayXY, thickmatrix); INTBSPL: begin if (isclosed) then begin Bctlptadjust (true, isanArc, numctls, arrayXY, thickmatrix); invertsplvertices (numctls, true, arrayXY); end else begin invertsplvertices (numctls, false, arrayXY); Bctlptadjust (false, isanArc, numctls, arrayXY, thickmatrix); end; (* else *) end; (* Interpolating Bsplines *) end; if ((not isclosed) and (isanArc)) then numctls := numctls - 1; (* UN-lie a little *) (* this is the scheme: * val := t-vector * Basis matrix * point matrix * [t^3 t^2 t 1] * [[Ms]] * [Pi-1 Pi Pi+1 Pi+2] * where "Pi-1" is "P sub (i-1)", etc. * * But we do this in a round about way: * Point matrix * basis * then * t-vector will yield the single value * * there are certainly faster ways to do this, * but this is the easiest to understand *) currpt := 1; case linepatt of solid : theresolution := MAXVECLENsp; dotted, dashed, dotdash : theresolution := 3 * MAXVECLENsp; {###} end; for Pi := 1 to (numctls - 1) do begin xctl[1] := float(arrayXY[Pi-1, 1]); xctl[2] := float(arrayXY[Pi, 1]); xctl[3] := float(arrayXY[Pi+1, 1]); xctl[4] := float(arrayXY[Pi+2, 1]); yctl[1] := float(arrayXY[Pi-1, 2]); yctl[2] := float(arrayXY[Pi, 2]); yctl[3] := float(arrayXY[Pi+1, 2]); yctl[4] := float(arrayXY[Pi+2, 2]); matXvector (basismatrix, xctl, xctl); matXvector (basismatrix, yctl, yctl); (* compute the delta-t increment for this segment based on a metric for subdivision *) intervals := numsubdivisions (xctl, yctl, theresolution); if ((linepatt = solid) and (intervals <= 2)) then intervals := intervals * 2; incr := 1.0 / intervals; (* avoid over-flowing the "pointmatrix" *) if ((currpt + intervals - 1) >= MAXSPLINESEGS) then begin complain (ERRREALBAD); writeln (logfile,'error: Too many spline segments required.'); writeln (logfile,' Reducing the number of control points to get output.'); goto 32; end; t := 0.0; while (t < 0.999999999) do begin pointmatrix[currpt, 1] := round (splinePosition (xctl, t)); pointmatrix[currpt, 2] := round (splinePosition (yctl, t)); if (varythicks) then begin wctl[1] := float(thickmatrix[Pi-1]); wctl[2] := float(thickmatrix[Pi ]); wctl[3] := float(thickmatrix[Pi+1]); wctl[4] := float(thickmatrix[Pi+2]); matXvector (catrommtx, wctl, wctl); (* requires using Catmull-Rom *) TTmatrix[currpt] := round (splinePosition (wctl, t)); end; t := t + incr; currpt := currpt + 1; end; (* while loop *) end; (* for loop *) 32: (* the END-condtion *) pointmatrix[currpt, 1] := round (splinePosition (xctl, 1.0)); pointmatrix[currpt, 2] := round (splinePosition (yctl, 1.0)); if (varythicks) then begin wctl[1] := thickmatrix[numctls-2]; wctl[2] := thickmatrix[numctls-1]; wctl[3] := thickmatrix[numctls]; wctl[4] := thickmatrix[numctls+1]; matXvector (catrommtx, wctl, wctl); (* requires using Catmull-Rom *) TTmatrix[currpt] := round (splinePosition (wctl, 1.0)); end; lastPoint := currpt; end; (* interpsplines *) {----------------------------------------------------------------} procedure drawSpline (splinetype : SplineKind; isclosed: boolean; isanArc: boolean; patt : LineStyle; numctls: integer; var arrayXY: ControlPoints; (* IN *) var pointmatrix: SplineSegments; (* OUT *) varythicks: boolean; var thickmatrix: ThickAryType; (* IN *) var TTmatrix: ThickAryType); (* OUT *) begin lastPoint := 0; case (splinetype) of CATROM : interpsplines (splinetype, isclosed, isanArc, patt, catrommtx, numctls, arrayXY, pointmatrix, varythicks, thickmatrix, TTmatrix); CARD : interpsplines (splinetype, isclosed, isanArc, patt, cardmtx, numctls, arrayXY, pointmatrix, varythicks, thickmatrix, TTmatrix); BSPL : interpsplines (splinetype, isclosed, isanArc, patt, bsplmtx, numctls, arrayXY, pointmatrix, varythicks, thickmatrix, TTmatrix); INTBSPL : interpsplines (splinetype, isclosed, isanArc, patt, bsplmtx, numctls, arrayXY, pointmatrix, varythicks, thickmatrix, TTmatrix); end; (*Case *) end; (* &&module TeXtyl *) {----------------------------------------------------------------} (* rotate a (x,y) point about mx, my *) procedure ptrotate (var x, y : integer; mx, my: integer; angle : real); var tmpx, tmpy : integer; cosa, sina : real; begin tmpx := x - mx; tmpy := y - my; cosa := cos(angle * DEGTORAD); sina := sin(angle * DEGTORAD); x := round(tmpx * cosa - tmpy * sina) + mx; y := round(tmpx * sina + tmpy * cosa) + my; end; {----------------------------------------------------------------} (* transform two line points: scale, rotate and translate *) procedure xfmlinepts (var x1, y1, x2, y2 : ScaledPts; offh, offv : ScaledPts; midx, midy : ScaledPts; scalefact : real; theta : real; dx, dy : ScaledPts; sx, sy : real); begin if ((sx = 0.0) or (sy = 0.0)) then begin complain (ERRBAD); writeln(logfile,'?? Some scale factor is Zero... continuing anyway'); end; (* scale about center of item*) if ((sx <> 1.0) or (sy <> 1.0)) then begin x1 := round((x1 - midx) * sx) + midx; x2 := round((x2 - midx) * sx) + midx; y1 := round((y1 - midy) * sy) + midy; y2 := round((y2 - midy) * sy) + midy; end; (* rotate if necessary *) if (theta <> 0.0) then begin (* rotate about the midpoint *) ptrotate(x1, y1, midx, midy, theta); ptrotate(x2, y2, midx, midy, theta); end; (* translate *) x1 := (x1 + round(dx * scalefact) + offh); x2 := (x2 + round(dx * scalefact) + offh); y1 := (y1 + round(dy * scalefact) + offv); y2 := (y2 + round(dy * scalefact) + offv); end; (* xfmlinepts *) {----------------------------------------------------------------} procedure xfmcontpts (var xpts : ControlPoints; xknots : integer; offh, offv : ScaledPts; midx, midy : ScaledPts; scalefact : real; theta : real; dx, dy : ScaledPts; sx, sy : real); var i : integer; begin (* scale about center of item *) if ((sx <> 1.0) or (sy <> 1.0)) then for i := 0 to xknots do begin xpts[i,1] := round((xpts[i,1] - midx) * sx) + midx; xpts[i,2] := round((xpts[i,2] - midy) * sy) + midy; end; if (theta <> 0.0) then begin (* rotate about center *) for i := 0 to xknots do begin ptrotate (xpts[i,1], xpts[i,2], midx, midy, theta); end; end; (* translate *) for i := 0 to xknots do begin xpts[i,1] := (xpts[i,1] + round(dx * scalefact) + offh); xpts[i,2] := (xpts[i,2] + round(dy * scalefact) + offv); end; end; (* xfmcontpts *) {----------------------------------------------------------------} (* convert into DVI space and offset by H & V *) procedure dvilinepts (var x1, y1, x2, y2 : ScaledPts; offh, offv : ScaledPts); begin x1 := (x1 + offh); x2 := (x2 + offh); y1 := (y1 * (-1) + offv); y2 := (y2 * (-1) + offv); end; {----------------------------------------------------------------} (* convert into DVI space and offset by H & V *) procedure dvicontpts (var xpts : ControlPoints; xknots : integer; offh, offv : ScaledPts); var i : integer; begin for i := 0 to xknots do begin xpts[i,1] := (xpts[i,1] + offh); xpts[i,2] := (xpts[i,2] * (-1) + offv); end; end; {----------------------------------------------------------------} (* transform all the figure's elements according to the top-level tranformation requirements in 1st Quadrant space. then reset the toplevel's xfms. *) procedure toplevelxfm (toplev, curfig : pItem; recurlevel : integer); var pi : pItem; null1, null2 : ScaledPts; old1, old2 : ScaledPts; midx, midy : ScaledPts; begin with toplev^ do begin midy := (BBty - BBby) div 2; midx := (BBrx - BBlx) div 2; end; pi := curfig^.body^.things; { if recur==0, this is same as toplev } while (pi <> nil) do begin with pi^ do begin case (kind) of Aline : begin xfmlinepts (lx1, ly1, lx2, ly2, 0, 0, midx, midy, 1.0, toplev^.figtheta, toplev^.fdx, toplev^.fdy, toplev^.fsx, toplev^.fsy); end; Aspline : begin xfmcontpts (spts, nsplknots, 0, 0, midx, midy, 1.0, toplev^.figtheta, toplev^.fdx, toplev^.fdy, toplev^.fsx, toplev^.fsy); end; Attspline : begin xfmcontpts (ttpts, nttknots, 0, 0, midx, midy, 1.0, toplev^.figtheta, toplev^.fdx, toplev^.fdy, toplev^.fsx, toplev^.fsy); end; Aarc : begin null1 := 0; null2 := 0; old1 := acentx; old2 := acenty; xfmlinepts (acentx, acenty, null1, null2, 0,0, midx, midy, 1.0, toplev^.figtheta, toplev^.fdx, toplev^.fdy, toplev^.fsx, toplev^.fsy); xfmcontpts (arcpts, narcknots + 1, 0, 0, old1, old2, 1.0, toplev^.figtheta, toplev^.fdx + (acentx - old1), toplev^.fdy + (acenty - old2), toplev^.fsx, toplev^.fsy); end; Alabel : begin null1 := 0; null2 := 0; xfmlinepts (labx, laby, null1, null2, 0, 0, midx, midy, 1.0, toplev^.figtheta, toplev^.fdx, toplev^.fdy, toplev^.fsx, toplev^.fsy); end; Abeam : ; (* not transformable *) Atieslur: ; (* not transformable *) Afigure : begin toplevelxfm (toplev, pi, recurlevel + 1); end; end; (* case *) end; (* with *) pi := pi^.nextitem; end; (* while *) if (recurlevel = 0) then begin (* reset the toplevel's xfms *) with toplev^ do begin figtheta := 0.0; fsx := 1.0; fsy := 1.0; fdx := 0; fdy := 0; end; end; end; {----------------------------------------------------------------} function scalefitfactor (actualwid, actualht, goalwid, goalht: ScaledPts): real; var sx, sy : real; begin sx := goalwid/actualwid; sy := goalht/actualht; if (sx < sy) then scalefitfactor := sx else scalefitfactor := sy; end; (* ---- The handlers for each primitive ---- * The result of calling each handler is either immediate * output to the buffer of the commands to produce the * primitive, OR the primitive gets pushed onto a stack/list * that defines a current 'figure' (set of prims) for * output at a later time * * Look at linehandle for a basic idea of how the handlers * work. the others follow pretty closely. *) {------------------------------------------------------------} procedure linehandle (figdepth : integer; scalefact: real; x1, y1, x2, y2 : ScaledPts; dvih, dviv : ScaledPts; (* possible dvi-offsets *) thk : VThickness; vk : VectKind; patt : LineStyle; minx, maxx, miny, maxy : ScaledPts; tx, ty: ScaledPts; sx, sy, r : real); var midx, midy : ScaledPts; lineitem : pItem; begin midx := (minx + maxx) div 2; midy := (miny + maxy) div 2; (* do local primitive -level transformations *) xfmlinepts (x1, y1, x2, y2, dvih, dviv, midx, midy, scalefact, r, tx, ty, sx, sy); if (figdepth = 0) then begin (* ---- do the primitive by itself *) (* re-transform it to the 4th Quadrant *) dvilinepts (x1, y1, x2, y2, h, v); (* global h and v posit *) IPUSH; TylLine (x1, y1, x2, y2, thk, vk, patt); IPOP; end else if (figdepth > 0) then begin (* ---- Pack it and stack it *) lineitem := NewItem (Aline); with lineitem^ do begin BBlx := minx; BBby := miny; BBrx := maxx; BBty := maxy; lx1 := x1; ly1 := y1; lx2 := x2; ly2 := y2; itemthick := thk; itemvec := vk; itempatt := patt; end; pushItem (figdepth, lineitem); end else if (figdepth < 0) then begin (* ---- just do it right away without any PUSH/POP pair *) (* this is the case when we are unpacking a figure for * immediate output *) TylLine (x1, y1, x2, y2, thk, vk, patt); end; end; (* linehandle *) (* --- Simple Splines -----*) {-----------------------------------------------------} procedure splinehandle (figdepth : integer; scalefact : real; thetype : SplineKind; isclosed : boolean; markdiam : integer; var contpts : ControlPoints; nknots : integer; dvih, dviv : ScaledPts; (* possible dvi-offsets *) thk : VThickness; vec : VectKind; patt : LineStyle; minx, maxx, miny, maxy : ScaledPts; tx, ty : ScaledPts; sx, sy, r : real); var midx, midy : ScaledPts; splineitem : pItem; i : integer; begin midx := (minx + maxx) div 2; midy := (miny + maxy) div 2; xfmcontpts (contpts, nknots, dvih, dviv, midx, midy, scalefact, r, tx, ty, sx, sy); if (figdepth = 0) then begin (* ---- do the primitive *) (* transform to 4th quad *) dvicontpts (contpts, nknots, h, v); IPUSH; TylSpline (thetype, isclosed, contpts, nknots, thk, vec, patt, markdiam); IPOP; end else if (figdepth > 0) then begin splineitem := NewItem (Aspline); with splineitem^ do begin BBlx := minx; BBby := miny; BBrx := maxx; BBty := maxy; itemthick := thk; itemvec := vec; itempatt := patt; nsplknots := nknots; spltype := thetype; sclosed := isclosed; dosmarks := markdiam; for i := 1 to nknots do begin spts[i,1] := contpts[i,1]; spts[i,2] := contpts[i,2]; end; end; pushItem (figdepth, splineitem); end else if (figdepth < 0) then begin TylSpline (thetype, isclosed, contpts, nknots, thk, vec, patt, markdiam); end; end; (* splinehandle *) (* --- Variable thickness splines ----- *) {-----------------------------------------------------} procedure ttsplhandle (figdepth : integer; scalefact : real; thetype : SplineKind; isclosed : boolean; markdiam : integer; contpts : ControlPoints; ttks : ThickAryType; nknots : integer; dvih, dviv : ScaledPts; (* possible dvi-offsets *) vec : VectKind; patt : LineStyle; minx, maxx, miny, maxy : ScaledPts; tx, ty : ScaledPts; sx, sy, r : real); var midx, midy : ScaledPts; ttsplitem : pItem; i : integer; begin midx := (minx + maxx) div 2; midy := (miny + maxy) div 2; xfmcontpts (contpts, nknots, dvih, dviv, midx, midy, scalefact, r, tx, ty, sx, sy); if (figdepth = 0) then begin (* transform to 4th quad *) dvicontpts (contpts, nknots, h, v); IPUSH; TylThickThinSpline (thetype, isclosed, contpts, ttks, nknots, vec, patt, markdiam); IPOP; end else if (figdepth > 0) then begin ttsplitem := NewItem (Attspline); with ttsplitem^ do begin BBlx := minx; BBby := miny; BBrx := maxx; BBty := maxy; itemvec := vec; itempatt := patt; nttknots := nknots; tspltype := thetype; dottmarks := markdiam; tclosed := isclosed; for i := 1 to nknots do begin ttpts[i,1] := contpts[i,1]; ttpts[i,2] := contpts[i,2]; ttarry[i] := ttks[i]; end; end; (* ttsplitem *) pushItem (figdepth, ttsplitem); end else if (figdepth < 0) then begin TylThickThinSpline (thetype, isclosed, contpts, ttks, nknots, vec, patt, markdiam); end; end; (* ttsplhandle *) (* ---- Musical Beams ---- *) {-----------------------------------------------------} procedure beamhandle (depth, siz : integer; bk : BeamKind; x1, y1, x2, y2 : ScaledPts); var bmitem : pItem; begin if (depth = 0) then begin dvilinepts (x1, y1, x2, y2, h, v); IPUSH; TylBeam (x1, y1, x2, y2, siz, bk); IPOP; end else if (depth > 0) then begin bmitem := NewItem (Abeam); with bmitem^ do begin BBlx := min(x1, x2); BBby := min(y1, y2); BBrx := max(x1, x2); BBty := max(y1, y2); bx1 := x1; by1 := y1; bx2 := x2; by2 := y2; staf := siz; bkind := bk; end; (* with *) pushItem (depth, bmitem); end else if (depth < 0) then begin TylBeam (x1, y1, x2, y2, siz, bk); end; (* else *) end; (* beamhandle *) (* ---- Musical Ties and Slurs ----- *) {-----------------------------------------------------} procedure tieslurhandle (depth: integer; pts : ControlPoints; numk : integer; minthick, maxthick : VThickness); var tsitem : pItem; i : integer; begin if (depth = 0) then begin dvicontpts (pts, numk, h, v); IPUSH; TylTieSlur (pts, numk, minthick, maxthick); IPOP; end else if (depth > 0) then begin tsitem := NewItem (Atieslur); with tsitem^ do begin ntknots := numk; for i := 1 to numk do begin tspts[i,1] := pts[i,1]; tspts[i,2] := pts[i,2]; end; minth := minthick; maxth := maxthick; end; (* with *) pushItem (depth, tsitem); end else if (depth < 0) then begin TylTieSlur (pts, numk, minthick, maxthick); end; (* else *) end; (* tieslurhandle *) {---------------------------------------------------------} procedure arccirclehandle (figdepth : integer; scalefact : real; cx, cy : ScaledPts; radius : ScaledPts; ang1, ang2 : integer; var contpts : ControlPoints; (* IN *) nknots : integer; dvih, dviv : ScaledPts; (* possible dvi-offsets *) thk : VThickness; vec : VectKind; patt : LineStyle; minx, maxx, miny, maxy : ScaledPts; tx, ty : ScaledPts; sx, sy, r : real); var midx, midy : ScaledPts; middlex, middley : ScaledPts; arcitem : pItem; i : integer; isclosedarc : boolean; begin midx := cx; middlex := (minx + maxx) div 2; midy := cy; middley := (miny + maxy) div 2; isclosedarc := (ang1 = ang2); { if (isclosedarc) then maxspanlen := round ((360.0 / 16.0) * DEGTORAD * radius) else maxspanlen := round ((abs(ang2 - ang1) / 16.0) * DEGTORAD * radius); { } xfmcontpts (contpts, nknots+1, dvih, dviv, midx, midy, scalefact, r, tx, ty, sx, sy); if (figdepth = 0) then begin (* ---- just do the primitive *) (* transform to 4th quad *) dvicontpts (contpts, nknots+1, h, v); IPUSH; doTylArc (isclosedarc, contpts, nknots, thk, vec, patt); IPOP; end else if (figdepth > 0) then begin arcitem := NewItem (Aarc); with arcitem^ do begin BBlx := minx; BBby := miny; BBrx := maxx; BBty := maxy; itemthick := thk; itemvec := vec; itempatt := patt; narcknots := nknots; acentx := cx; acenty := cy; aradius := radius; firstang := ang1; lastang := ang2; for i := 0 to nknots+1 do begin arcpts[i,1] := contpts[i,1]; arcpts[i,2] := contpts[i,2]; end; end; pushItem (figdepth, arcitem); end else if (figdepth < 0) then begin doTylArc (isclosedarc, contpts, nknots, thk, vec, patt); end; end; (* arccirclehandle *) {---------------------------------------------------------} procedure labelhandle (depth : integer; scalefact: real; lax, lay : ScaledPts; dvih, dviv : ScaledPts; (* possible dvi-offsets *) style : integer; phrase : strng; tx, ty : ScaledPts); var labitem : pItem; null1, null2 : ScaledPts; begin (* xfm the label point if necessary *) lax := lax + round(tx * scalefact); lay := lay + round(ty * scalefact); if (depth = 0) then begin null1 := 0; null2 := 0; dvilinepts (lax, lay, null1, null2, h, v); IPUSH; TylLabel (lax, lay, style, phrase.str, phrase.len); IPOP; end else if (depth > 0) then begin labitem := NewItem (Alabel); with labitem^ do begin labx := lax; laby := lay; fontstyle := style; strcopy (phrase.str, labeltext.str, phrase.len); labeltext.len := phrase.len; end; pushItem (depth, labitem); end else if (depth < 0) then begin TylLabel (lax, lay, style, phrase.str, phrase.len); end; end; (* #### Insert new handlers here for new "primitives" i.e., names callable from the \special[tyl ...] level *) {----------------------------------------------------------------} (* transform the current bbox coordinates, and output the new one *) procedure newbbox (var minx, maxx, miny, maxy : ScaledPts; midx, midy : ScaledPts; sx, sy, rot : real; tx, ty : ScaledPts); var (* coords of full bbox for transformation [n/s][e/w][x/y] *) nex, ney, sex, sey, swx, swy, nwx, nwy: ScaledPts; temp1, temp2 : integer; begin (* describe and transform the bbox *) nwx := round (minx * sx); nex := round (maxx * sx); sex := round (maxx * sx); swx := round (minx * sx); ney := round (maxy * sy); nwy := round (maxy * sy); swy := round (miny * sy); sey := round (miny * sy); ptrotate (nex, ney, midx, midy, rot); ptrotate (sex, sey, midx, midy, rot); ptrotate (swx, swy, midx, midy, rot); ptrotate (nwx, nwy, midx, midy, rot); nex := nex + tx; sex := sex + tx; swx := swx + tx; nwx := nwx + tx; ney := ney + ty; sey := sey + ty; swy := swy + ty; nwy := nwy + ty; (* now find the actual extents of the bbox *) temp1 := min (nex, nwx); temp2 := min (swx, sex); minx := min (temp1, temp2); temp1 := min (ney, nwy); temp2 := min (swy, sey); miny := min (temp1, temp2); temp1 := max (nex, nwx); temp2 := max (swx, sex); maxx := max (temp1, temp2); temp1 := max (ney, nwy); temp2 := max (swy, sey); maxy := max (temp1, temp2); end; {-----------------------------------------------} (* find the bounding box of the list of primitives and/or sub-figures in this Item *) procedure findBBox (blot : pItem; var mnx, mxx, mny, mxy : ScaledPts); var pi : pItem; bmnx, bmxx, bmny, bmxy, midx, midy : ScaledPts; (* bbox [min/max][x/y] *) tmnx, tmxx, tmny, tmxy : ScaledPts; (* temporary, in case of recursion *) null1, null2 : ScaledPts; prescale, postscale : real; old1, old2 : ScaledPts; begin bmnx := TWO24; bmny := TWO24; bmxx := -TWO24; bmxy :=-TWO24; if (blot^.kind = Afigure) then begin (* afigure *) pi := blot^.body^.things; while (pi <> nil) do begin (* find the current bbox of the list of items here *) if (pi^.kind = Afigure) then begin (* recur *) findBBox (pi, tmnx, tmxx, tmny, tmxy); bmnx := min (bmnx, tmnx); bmny := min (bmny, tmny); bmxx := max (bmxx, tmxx); bmxy := max (bmxy, tmxy); end else begin bmnx := min (bmnx, pi^.BBlx); bmny := min (bmny, pi^.BBby); bmxx := max (bmxx, pi^.BBrx); bmxy := max (bmxy, pi^.BBty); end; pi := pi^.nextitem; end; (* while *) (* now transform the items inside, AND the bbox *) pi := blot^.body^.things; midx := (bmnx + bmxx) div 2; midy := (bmny + bmxy) div 2; (* now take care of any pre and post size requirements *) (* see also the "figurehandle" proc. *) with blot^ do begin (* ### Keep this scaling biz here, too, for now. May blast it later *) if ((preWid <> 0) and (preHt <> 0)) then begin prescale := scalefitfactor ((bmxx - bmnx), (bmxy - bmny), preWid, preHt); fsx := fsx * prescale; fsy := fsy * prescale; end; if ((postWid <> 0) and (postHt <> 0)) then begin postscale := scalefitfactor ((bmxx - bmnx), (bmxy - bmny), postWid, postHt); fsx := fsx * postscale; fsy := fsy * postscale; end; (* the actual scale-up is taken care of later in this proc. *) end; (* with *) while (pi <> nil) do begin with pi^ do begin case (kind) of Aline : begin xfmlinepts (lx1, ly1, lx2, ly2, 0, 0, midx, midy, 1.0, blot^.figtheta, blot^.fdx, blot^.fdy, blot^.fsx, blot^.fsy); end; Aspline : begin xfmcontpts (spts, nsplknots, 0, 0, midx, midy, 1.0, blot^.figtheta, blot^.fdx, blot^.fdy, blot^.fsx, blot^.fsy); end; Attspline : begin xfmcontpts (ttpts, nttknots, 0, 0, midx, midy, 1.0, blot^.figtheta, blot^.fdx, blot^.fdy, blot^.fsx, blot^.fsy); end; Aarc : begin null1 := 0; null2 := 0; old1 := acentx; old2 := acenty; xfmlinepts (acentx, acenty, null1, null2, 0,0, midx, midy, 1.0, blot^.figtheta, blot^.fdx, blot^.fdy, blot^.fsx, blot^.fsy); xfmcontpts (arcpts, narcknots + 1, 0, 0, old1, old2, 1.0, blot^.figtheta, blot^.fdx + (acentx - old1), blot^.fdy + (acenty - old2), blot^.fsx, blot^.fsy); end; Alabel : begin null1 := 0; null2 := 0; xfmlinepts (labx, laby, null1, null2, 0,0, midx, midy, 1.0, blot^.figtheta, blot^.fdx, blot^.fdy, blot^.fsx, blot^.fsy); end; Abeam : ; (* not transformable *) Atieslur: ; (* not transformable *) Afigure : ; (* do not need to re-transform *) end; (* case *) end; (* with *) pi := pi^.nextitem; end; (* while *) (* transform the bbox, and re-find the new bbox *) newbbox (bmnx, bmxx, bmny, bmxy, midx, midy, blot^.fsx, blot^.fsy, blot^.figtheta, blot^.fdx, blot^.fdy); mnx := bmnx; mny := bmny; mxx := bmxx; mxy := bmxy; end (* if *) else (* some other primitive *) begin mnx := blot^.BBlx; mny := blot^.BBby; mxx := blot^.BBrx; mxy := blot^.BBty; end; (* else *) end; (* findBBox *) {---------------------------------------------------------} (* traverse the list, determining the current bounding box for * the items. We need this to find the mid-point * for doing any remaining rotations *) procedure traverse (thefig, theitem : pItem); var minx, maxx, miny, maxy : ScaledPts; curminx, curmaxx, curminy, curmaxy : ScaledPts; begin minx := TWO24; maxx := -TWO24; miny := TWO24; maxy := -TWO24; while (theitem <> nil) do begin if (theitem^.kind = Afigure) then begin (* recur *) findBBox (theitem, curminx, curmaxx, curminy, curmaxy); with theitem^ do begin BBlx := curminx; BBby := curminy; BBrx := curmaxx; BBty := curmaxy; (* reset the symbol's parameters since all the primitives in it have now been transformed according to the previous specifications *) figtheta := 0.0; fsx := 1.0; fsy := 1.0; fdx := 0; fdy := 0; preWid := 0; preHt := 0; postWid := 0; postHt := 0; end; (* with *) minx := min (minx, curminx); miny := min (miny, curminy); maxx := max (maxx, curmaxx); maxy := max (maxy, curmaxy); end (* if a figure/symbol*) else begin (* a primitive *) with theitem^ do begin minx := min (minx, BBlx); miny := min (miny, BBby); maxx := max (maxx, BBrx); maxy := max (maxy, BBty); end; (* with *) end; (* else *) theitem := theitem^.nextitem; end; (* while *) with thefig^ do begin (* set the bounding box for this upper-level symbol defn *) BBlx := minx; BBby := miny; BBrx := maxx; BBty := maxy; end; (* with *) end; (* traverse *) (* ----- Figure symbols ----- *) {---------------------------------------------------} procedure figurehandle (globalsymlist, symbollist : pItem; dopush : integer); const DoItNow = -1; NoScale = 1; var pi, curfig : pItem; midx, midy : ScaledPts; null1, null2 : ScaledPts; prescale, postscale : real; tmnx, tmny, tmxx, tmxy : ScaledPts; begin (* figurehandle *) (* PUSH. traverse the lists (recursively if necessary) and * compute the transformed points. * Convert to 4th quadrant and offset by H & V. * We can do this destructively here * since we're going to output them right away anyhow. * Then call each respective primitive handler with a level * of -1 to indicate to do its job immediately. * POP. *) curfig := symbollist; pi := curfig^.body^.things; (* find and set the bounding box for the figure's sub-symbols and primitives *) if (dopush > 0) then traverse (curfig, pi); (* We eventually transform the items to 4th Quadrant DVI space and output them! *) pi := curfig^.body^.things; midy := (globalsymlist^.BBby + globalsymlist^.BBty) div 2; midx := (globalsymlist^.BBlx + globalsymlist^.BBrx) div 2; if (dopush > 0) then begin (* the top-level figure for outputting *) (* convert the bounding box because we are about to enter into DVI space, and all calls to handlers hereafter are in terms of DVI coordinates *) with globalsymlist^ do begin (* Since there were external specifications about this figure, fit the current figure's actual size to the "pre" size (specified by W marker) and/or to the "post" size (specified by the F marker). We do this by simple scaling, *without* changing the midpoint of the bounding box, just its extents *) if ((preWid <> 0) and (preHt <> 0)) then begin prescale := scalefitfactor ((BBrx - BBlx), (BBty - BBby), preWid, preHt); fsx := fsx * prescale; fsy := fsy * prescale; end; if ((postWid <> 0) and (postHt <> 0)) then begin postscale := scalefitfactor ((BBrx - BBlx), (BBty - BBby), postWid, postHt); fsx := fsx * postscale; fsy := fsy * postscale; end; tmnx := BBlx; tmny := BBby; tmxx := BBrx; tmxy := BBty; xfmlinepts (tmnx, tmny, tmxx, tmxy, 0,0, midx, midy, 1.0, 0.0, 0, 0, fsx, fsy); toplevelxfm (globalsymlist, globalsymlist, 0); dviBBlx := tmnx; dviBBrx := tmxx; dviBBby := tmny; dviBBty := tmxy; xfmlinepts (dviBBlx, dviBBby, dviBBrx, dviBBty, 0,0, midx, midy, 1.0, 0.0, - (tmnx - BBlx), - (tmny - BBby), 1.0, 1.0); fdx := fdx - (tmnx - BBlx); fdy := fdy - (tmny - BBby); end; dvilinepts (dviBBlx, dviBBby, dviBBrx, dviBBty, h, v); pgfigurenum := pgfigurenum + 1; (* We are ready to output the figure to the page *) writeln(logfile); write(logfile,'Figure #',pgfigurenum:0,' on page ',currpagenum:0,' is approx. '); { write(logfile,((globalsymlist^.BBty - globalsymlist^.BBby) div SPPERPT):0,' pts high and '); writeln(logfile,((globalsymlist^.BBrx - globalsymlist^.BBlx) div SPPERPT):0,' pts wide (actual size)'); } write(logfile,((tmxy - tmny) div SPPERPT):0,' pts high and '); writeln(logfile,((tmxx - tmnx) div SPPERPT):0,' pts wide (actual size)'); IPUSH; end; while (pi <> nil) do begin with pi^ do begin case (kind) of Aline : begin dvilinepts (lx1, ly1, lx2, ly2, h, v); (* DVI h and v posit *) with globalsymlist^ do linehandle (DoItNow, NoScale, pi^.lx1, pi^.ly1, pi^.lx2, pi^.ly2, 0, 0, pi^.itemthick, pi^.itemvec, pi^.itempatt, dviBBlx, dviBBrx, dviBBby, dviBBty, fdx, -fdy, fsx, fsy, -figtheta); end; (* Aline *) Aspline : begin dvicontpts (spts, nsplknots, h, v); with globalsymlist^ do splinehandle (DoItNow, NoScale, pi^.spltype, pi^.sclosed, pi^.dosmarks, pi^.spts, pi^.nsplknots, 0, 0, pi^.itemthick, pi^.itemvec, pi^.itempatt, dviBBlx, dviBBrx, dviBBby, dviBBty, fdx, -fdy, fsx, fsy, -figtheta); end; (* Aspline *) Attspline : begin dvicontpts (ttpts, nttknots, h, v); with globalsymlist^ do ttsplhandle (DoItNow, NoScale, pi^.tspltype, pi^.tclosed, pi^.dottmarks, pi^.ttpts, pi^.ttarry, pi^.nttknots, 0, 0, pi^.itemvec, pi^.itempatt, dviBBlx, dviBBrx, dviBBby, dviBBty, fdx, -fdy, fsx, fsy, -figtheta); end; (* Attspline *) Abeam : begin dvilinepts (bx1, by1, bx2, by2, h, v); beamhandle (DoItNow, staf, bkind, bx1, by1, bx2, by2); end; (* Abeam *) Atieslur : begin dvicontpts (tspts, ntknots, h, v); tieslurhandle (DoItNow, tspts, ntknots, minth, maxth); end; (* a tie or slur *) Aarc : begin dvicontpts (arcpts, narcknots + 1, h, v); with globalsymlist^ do arccirclehandle (DoItNow, NoScale, pi^.acentx, pi^.acenty, pi^.aradius, pi^.firstang, pi^.lastang, pi^.arcpts, pi^.narcknots, 0, 0, pi^.itemthick, pi^.itemvec, pi^.itempatt, dviBBlx, dviBBrx, dviBBby, dviBBty, fdx, -fdy, fsx, fsy, -figtheta); end; (* arc *) Alabel : begin null1 := 0; null2 := 0; dvilinepts (labx, laby, null1, null2, h, v); with globalsymlist^ do labelhandle (DoItNow, NoScale, pi^.labx, pi^.laby, 0, 0, pi^.fontstyle, pi^.labeltext, fdx, -fdy); end; (* label *) Afigure : begin (* recur *) figurehandle (globalsymlist, pi, 0); end; (* another symbol *) end; (* case *) end; (* with *) pi := pi^.nextitem; end; (* while *) if (dopush > 0) then begin IPOP; end; end; (* figurehandle *) (* %%% *) {-----------------------------------------------------} procedure mainhandlespecials (specnum, numpbytes : integer); (* specnum is the DVI-number of the special * numpbytes is the number of parameter bytes *) label 888; const PARSLEN = 50; (* Length of the byte-string-cache *) EMPTY = 0; type charset = set of char; var siz, numknots : integer; (* Lots of temp vars that we use *) x1, y1, x2, y2 : integer; sx100, sy100 : real; transx, transy : ScaledPts; rot : real; SPscale : real; cpts : ControlPoints; thk : VThickness; patt : LineStyle; TTary : ThickAryType; vk : VectKind; bk : BeamKind; markdiam : integer; radius, ang1, ang2 : integer; phrase : strng; style : integer; nam : strng; sysnam : strng; (* the first parameter of the \special *) let : char; i, gotten : integer; b : OctByt; pi : pItem; minx, miny, maxx, maxy : ScaledPts; maxthk, minthk : integer; tylnam, beginfigurenam, (* names used for string to string comparisons *) endfigurenam, linenam, splinenam, ttsplnam, beamnam, tieslurnam, arcnam, labelnam, paramnam {internal} : charstring; splinetype : SplineKind; isclosedspline : boolean; parsearray : array [1..PARSLEN] of OctByt; (* cache of bytes to run through *) parsposit, parsmax : integer; (* current and max position in cache *) usingstream : boolean; (* whether we read/parse using cache or from file *) (*-------------------------------------------------------------- These procedures depend on the correct ordering of GETs with respect to the number of bytes read in so far. precond: byte "b" has been read and gotten < numpbytes postcond: byte "b" has been read iff gotten < numpbytes. If your impl. definition of READ is non-standard, you will have to dink with the ordering and be really careful of keeping track of 'gotten' and 'numpbytes' variables --------------------------------------------------------------*) function nextpbyte : integer; begin if (usingstream) then begin if (gotten < numpbytes) then begin nextpbyte := Dget1byte; gotten := gotten + 1; end else nextpbyte := EMPTY; end else begin (* not using stream *) if (parsposit <= parsmax) then begin nextpbyte := parsearray[parsposit]; parsposit := parsposit + 1; end else begin (* at end of parse array, so read from stream now *) usingstream := true; if (gotten < numpbytes) then begin nextpbyte := Dget1byte; gotten := gotten + 1; end else nextpbyte := EMPTY; end; end; (* else *) end; (* !!!!! Make sure all these predicates jive correctly with the key-letter definitions *) {__________________________________________________________________} function isanumber (b : integer) : boolean; begin isanumber := ((b >= xord['0']) and (b <= xord['9'])); end; function isaletter (b : integer) : boolean; begin isaletter := (((b >= xord['A']) and (b <= xord['Z'])) or ((b >= xord['a']) and (b <= xord['z'])) or (b = xord['@']) or (b = xord['"']) ); end; function isaspace (b : integer) : boolean; begin isaspace := ((b = xord[' ']) or (b = CR) or (b = LF) or (b = HT) or (b = FF)); end; function isdelimiter (b : integer) : boolean; begin (* not a key-letter *) isdelimiter := (((b < xord['A']) or (b > xord['Z'])) and ((b < xord['a']) or (b > xord['z'])) and (b <> xord['@']) and (b <> xord['"']) ); end; function isnotnull (b : integer) : boolean; begin isnotnull := (b <> EMPTY); end; {__________________________________________________________________} function getnumber : integer; var n : integer; isneg : boolean; begin n := 0; isneg := false; while ( (isnotnull (b)) and (not (isanumber (b)))) do begin (* not a numeral *) if (b = xord['-']) then isneg := true; b := nextpbyte; end; while (isaspace (b)) do (* Skip spaces *) b := nextpbyte; while ( (isnotnull (b)) and isanumber (b)) do begin (* a numeral *) n := n * 10 + (b - xord['0']); b := nextpbyte; end; if ((gotten = numpbytes) and isanumber (b)) then begin (* end condition *) n := n * 10 + (b - xord['0']); end; if (isneg) then getnumber := -(n) else getnumber := n; end; {__________________________________________________________________} function getletter : char; var k : char; begin k := ' '; while ( (isnotnull (b)) and (isdelimiter (b) and not (isaspace (b)))) do begin (* non letter *) b := nextpbyte; end; if ( (isnotnull (b)) and ( isaletter (b) or isaspace (b) and not (isanumber (b)))) then begin k := xchr[b]; b := nextpbyte; end; getletter := k; end; {__________________________________________________________________} function getanything : char; var k : char; begin k := ' '; while (not (isnotnull (b))) do begin (* not usable *) b := nextpbyte; end; if (isnotnull (b)) then begin k := xchr[b]; b := nextpbyte; end; getanything := k; end; {**************************************************** The following routines look for key - letter tokens that indicate certain attributes for a primitive. Currently, the letters used are: S for scaled-points measurement P for printers points M millimeters measurement C use a Circular vector for drawing H Horizontal-pen vector V Vertical vector B B-spline I Interpolating B-spline K Catmull-Rom spline D Cardinal spline U Open spline O closed spline X put marks on spline control pts T Transformation marker R Regular beam characters G Grace Beam characters @ Specify center-point for arc/circle L Line-style F for beginfigure: Fit figure to wid/ht W for beginfigure: figure was created at this wid & ht **************************************************} {__________________________________________________________________} procedure gettransforms (var sc1, sc2, r : real; var tr1, tr2 : integer); label 22; var i : integer; dun : boolean; begin sc1 := 1.0; sc2 := 1.0; tr1 := 0; tr2 := 0; r := 0.0; i := parsposit - 1; if (i < 1) then begin goto 22; (* exit with defaults *) end; dun := false; while ((i < parsmax) and not dun) do begin if (isaletter(parsearray[i])) then begin if ((parsearray[i] = xord['t']) or (parsearray[i] = xord['T'])) then begin if (isdelimiter(parsearray[i+1]) and isdelimiter(parsearray[i-1])) then begin (* get transform parameters *) sc1 := getnumber / 100.0; sc2 := getnumber / 100.0; tr1 := getnumber; tr2 := getnumber; r := float(getnumber); (* degrees about primitive center *) if (r < 0.0) then r := r + 360.0; dun := true; end; end; end; i := i + 1; end; (* while *) 22: end; (* gettransforms *) {__________________________________________________________________} function findmarker (markset : charset) : integer; label 1111; var i, sym : integer; dun : boolean; begin i := parsposit - 1; sym := EMPTY; if (i < 1) then goto 1111; dun := false; while ((i < parsmax) and not dun) do begin if (isaletter(parsearray[i])) then begin if (xchr[ parsearray[i] ] in markset) then begin if (isdelimiter (parsearray[i+1]) and isdelimiter (parsearray[i-1])) then begin sym := xord[tolowercase(xchr[parsearray[i]])]; dun := true; end; end; end; (* if a letter *) i := i + 1; end; (* while *) 1111: findmarker := sym; end; function findscale : integer; begin findscale := findmarker(['s','S','p','P','m','M']); end; function findvectkind : integer; begin findvectkind := findmarker(['c','C','h','H','v','V']); end; function findlinestyle : integer; begin findlinestyle := findmarker(['l','L']); end; function findbeamkind : integer; begin findbeamkind := findmarker(['r','R','g','G']); end; function findsplinekind : integer; begin findsplinekind := findmarker(['b','B','i','I','k','K','d','D']); end; function findsplclosure : integer; begin findsplclosure := findmarker(['o','O','u','U']); end; function findatsign : integer; begin findatsign := findmarker(['@']); end; function finddotmark : integer; begin finddotmark := findmarker(['x','X']); end; function findfigdimens : integer; begin findfigdimens := findmarker(['w','W']); end; function findfitsizes : integer; begin findfitsizes := findmarker(['f','F']); end; {_________________________________________________} function thescaleof (scal : integer) : real; begin if (scal = xord['s']) then thescaleof := 1 * magfactor else if (scal = xord['p']) then thescaleof := SPPERPT * magfactor else if (scal = xord['m']) then thescaleof := SPPERMM * magfactor else if (scal = EMPTY) then thescaleof := SPPERPT * magfactor; end; function thevectorof (vkin : integer) : VectKind; begin if (vkin = xord['c']) then thevectorof := VKCirc else if (vkin = xord['v']) then thevectorof := VKVert else if (vkin = xord['h']) then thevectorof := VKHort else if (vkin = EMPTY) then thevectorof := VKCirc; end; function thestyleof (linest : integer) : LineStyle; begin if ((linest > 3) or (linest < 0)) then linest := 0; case linest of 0 : thestyleof := solid; 1 : thestyleof := dotted; 2 : thestyleof := dashed; 3 : thestyleof := dotdash; end; end; (* -----!!!!!!!!!!!! HandleSpecials !!!!!!!!!!!!!------ *) begin tylnam := 'tyl'; beginfigurenam := 'beginfigure'; endfigurenam := 'endfigure'; linenam := 'line'; splinenam := 'spline'; ttsplnam := 'ttspline'; beamnam := 'beam'; tieslurnam := 'tieslur'; arcnam := 'arc'; labelnam := 'label'; paramnam := 'param'; usingstream := true; (* getting bytes from dvifile *) specstart := DVIMark - (specnum - 239 + 1) - 1; ourxpos := h; ourypos := v; (* note the global DVI (h,v) coords *) i := 1; b := Dget1byte; (* prime the reading scheme *) gotten := (specnum - 239 + 1); while (isaspace(b)) do b := nextpbyte; let := getletter; while (let <> ' ') do (* get the name of the system --- Hopefully 'tyl' *) begin sysnam.str[i] := tolowercase(let); sysnam.len := i; i := i + 1; let := getletter; end; sysnam.str[i] := chr(32); (* end of string *) if (not streq (sysnam.str, tylnam, 3)) then (* TeXtyl doesnt know about this special *) begin write (logfile,'The special: '); writestrng(sysnam,true); writeln(logfile,' is not tyl-able. Skipping...'); while (gotten < numpbytes) do b := nextpbyte; goto 888; end; (* OTHERWISE: all is okay. Lets look for a primitive to tyl *) while (isdelimiter(b)) do begin b := nextpbyte; end; i := 1; let := getletter; {xchr[b];} while (not (isdelimiter(xord[let]))) do (* get the name of the primitive *) begin nam.str[i] := tolowercase(let); nam.len := i; i := i + 1; let := getletter; end; nam.str[i] := chr(32); (* end of string *) let := xchr[b]; (* Now, fill the parse array with bytes so that we can get the given parameters, and infer the defaulted params *) parsmax := min (PARSLEN, ((numpbytes - gotten) + 1)); if (parsmax > 1) then begin parsearray[1] := xord[' ']; (* we need this *) parsearray[2] := b; (* start filling *) for i := 3 to parsmax do begin (* fill rest *) parsearray[i] := nextpbyte; end; parsposit := 1; usingstream := false; (* now we look at bytes in parse array *) b := nextpbyte; (* start it *) end else begin usingstream := true; parsposit := -1; (* undefined *) end; (* --- BEGINFIGURE ---- *) if streq(nam.str, beginfigurenam, 3) then begin multifigure := multifigure + 1; i := findscale; SPscale := thescaleof (i); gettransforms (sx100, sy100, rot, transx, transy); (* store all the primitives on pageitems, and dont output them until we get a endfigure. this way, we can take care of dealing with all the primitives according to some global tranformation for the whole figure *) pi := NewItem (Afigure); with pi^ do begin figtheta := rot; fsx := sx100; fsy := sy100; fdx := round (transx * SPscale); fdy := round (transy * SPscale); depthnumber := multifigure; (* we're at a new level *) i := findfigdimens; if (i <> EMPTY) then begin preWid := round (getnumber * SPscale); preHt := round (getnumber * SPscale); end; i := findfitsizes; if (i <> EMPTY) then begin postWid := round (getnumber * SPscale); postHt := round (getnumber * SPscale); end; end; (* with *) BackupInBuf (DVIMark - specstart); pushItem (multifigure - 1, pi); goto 888; end; (* ---- ENDFIGURE ---- *) if streq(nam.str, endfigurenam, 3) then begin multifigure := multifigure - 1; if (multifigure < 0) then begin complain (ERRBAD); write(logfile,'Warning: Too many "endfigure"s !'); multifigure := 0; end; BackupInBuf (DVIMark - specstart); if (multifigure = 0) then begin (* go do our set of figures (within figures...) *) figurehandle (pageitems, pageitems, 1); dispose (pageitems); (* ### should maybe garbage collect here *) pageitems := nil; end; (* if *) goto 888; end; (* --- LINE --- *) if streq(nam.str, linenam, 3) then begin i := findscale; SPscale := thescaleof(i); gettransforms (sx100, sy100, rot, transx, transy); thk := getnumber; (* get the vector thickness *) if (thk < 1) then begin complain (ERRBAD); writeln(logfile,'?? Thickness not found. Setting to 1'); thk := 1; end; i := findvectkind; vk := thevectorof (i); i := findlinestyle; if (i <> EMPTY) then patt := thestyleof (getnumber) else patt := solid; x1 := round (getnumber * SPscale); y1 := round (getnumber * SPscale); x2 := round (getnumber * SPscale); y2 := round (getnumber * SPscale); minx := min (x1, x2); maxx := max (x1, x2); miny := min (y1, y2); maxy := max (y1, y2); BackupInBuf (DVIMark - (specstart)); cmd1byte (OURFONTFLAG); linehandle (multifigure, SPscale, x1, y1, x2, y2, 0, 0, thk, vk, patt, minx, maxx, miny, maxy, transx, transy, sx100, sy100, rot); end (* line *) (* ---- THE SPLINES ---- *) else if (streq(nam.str, splinenam, 3) or streq(nam.str, ttsplnam,3)) then begin i := findscale; SPscale := thescaleof (i); gettransforms (sx100, sy100, rot, transx, transy); if streq(nam.str, splinenam, 3) then begin thk := getnumber; if (thk < 1) then begin complain (ERRBAD); writeln(logfile,'Spline Thickness not found. Setting to 1'); thk := 1; end; end; i := findvectkind; vk := thevectorof (i); i := findlinestyle; if (i <> EMPTY) then patt := thestyleof (getnumber) else patt := solid; i := findsplinekind; if (i = xord['b']) then splinetype := BSPL else if (i = xord['i']) then splinetype := INTBSPL else if (i = xord['k']) then splinetype := CATROM else if (i = xord['d']) then splinetype := CARD else if (i = EMPTY) then splinetype := CATROM; i := findsplclosure; if (i = xord['o']) then isclosedspline := true else if (i = xord['u']) then isclosedspline := false else if (i = EMPTY) then isclosedspline := false; i := finddotmark; if (i = xord['x']) then markdiam := getnumber else if (i = EMPTY) then markdiam := 0; numknots := min (getnumber, MAXCTLPTS); if (numknots < 1) then begin complain (ERRBAD); writeln(logfile,'Number of spline/ttspline knot points not found. Setting to 1'); numknots := 1; end; minx := TWO24; miny := TWO24; maxx := -TWO24; maxy := -TWO24; for i := 0 to (numknots + 3) do begin cpts[i,1] := 0; cpts[i,2] := 0; end; (* for *) for i := 1 to numknots do begin x1 := round (getnumber * SPscale); cpts[i,1] := x1; if (x1 < minx) then minx := x1; if (x1 > maxx) then maxx := x1; y1 := round (getnumber * SPscale); cpts[i,2] := y1; if (y1 < miny) then miny := y1; if (y1 > maxy) then maxy := y1; end; (* for *) if streq(nam.str, ttsplnam, 3) then begin for i := 1 to numknots do begin TTary[i] := getnumber; end; end; BackupInBuf (DVIMark - (specstart)); cmd1byte (OURFONTFLAG); if streq(nam.str, splinenam, 3) then splinehandle (multifigure, SPscale, splinetype, isclosedspline, markdiam, cpts, numknots, 0, 0, thk, vk, patt, minx, maxx, miny, maxy, transx, transy, sx100, sy100, rot) else ttsplhandle (multifigure, SPscale, splinetype, isclosedspline, markdiam, cpts, TTary, numknots, 0, 0, vk, patt, minx, maxx, miny, maxy, transx, transy, sx100, sy100, rot); end (* splines *) (* --- BEAMS ---- *) else if streq(nam.str, beamnam, 4) then begin i := findscale; SPscale := thescaleof (i); (* no transforms *) siz := getnumber; (* the staffsize *) i := findbeamkind; if (i = xord['g']) then bk := grace else if (i = xord['r']) then bk := regular else if (i = EMPTY) then bk := regular; x1 := round (getnumber * SPscale); y1 := round (getnumber * SPscale); x2 := round (getnumber * SPscale); y2 := round (getnumber * SPscale); BackupInBuf (DVIMark - (specstart)); cmd1byte (OURFONTFLAG); beamhandle (multifigure, siz, bk, x1, y1, x2, y2); end (* beam *) (* ---- TIES AND SLURS ---- *) else if streq(nam.str, tieslurnam, 3) then begin i := findscale; SPscale := thescaleof (i); minthk := getnumber; if (minthk < 1) then begin complain (ERRBAD); writeln(logfile,'Tie/Slur Min Thickness not found. Setting to 1'); minthk := 1; end; maxthk := getnumber; if (maxthk < 1) then begin complain (ERRBAD); writeln(logfile,'Tie/Slur MaxThickness not found. Setting to 1'); maxthk := 1; end; numknots := min (getnumber, MAXCTLPTS); if (numknots < 1) then begin complain (ERRBAD); writeln(logfile,'Tie/Slur Number of knot points not found. Setting to 1. Should be 5'); numknots := 1; end; for i := 1 to numknots do begin cpts[i,1] := round (getnumber * SPscale); cpts[i,2] := round (getnumber * SPscale); end; (* for *) BackupInBuf (DVIMark - (specstart)); cmd1byte (OURFONTFLAG); tieslurhandle (multifigure, cpts, numknots, minthk, maxthk); end (* ties and slurs *) (* --------- ARCS and CIRCLES --------- *) else if streq (nam.str, arcnam, 3) then begin i := findscale; SPscale := thescaleof (i); gettransforms (sx100, sy100, rot, transx, transy); thk := getnumber; if (thk < 1) then begin complain (ERRBAD); writeln(logfile,'Arc Thickness not found. Setting to 1'); thk := 1; end; i := findvectkind; vk := thevectorof (i); i := findlinestyle; if (i <> EMPTY) then patt := thestyleof (getnumber) else patt := solid; radius := round (getnumber * SPscale); if (radius = 0) then radius := round(1 * SPscale); i := findatsign; if (i <> EMPTY) then begin x2 := round (getnumber * SPscale); y2 := round (getnumber * SPscale); end else begin x2 := 0; y2 := 0; (* assume center at origin *) end; ang1 := getnumber; if (abs(ang1) > 360) then ang1 := ang1 mod 360; ang2 := getnumber; if (abs(ang2) > 360) then ang2 := ang2 mod 360; minx := TWO24; miny := TWO24; maxx := -TWO24; maxy := -TWO24; if (ang1 = ang2) then begin (* a circle *) defineCircleCpts (radius,x2,y2, cpts, numknots); end else begin (* a real arc *) definearcpts (radius, x2,y2, ang1, ang2, cpts, numknots); end; for i := 1 to numknots do begin x1 := cpts[i,1]; if (x1 < minx) then minx := x1; if (x1 > maxx) then maxx := x1; y1 := cpts[i,2]; if (y1 < miny) then miny := y1; if (y1 > maxy) then maxy := y1; end; (* for *) BackupInBuf (DVIMark - (specstart)); cmd1byte (OURFONTFLAG); arccirclehandle (multifigure, SPscale, x2, y2, radius, ang1, ang2, cpts, numknots, 0, 0, thk, vk, patt, minx, maxx, miny, maxy, transx, transy, sx100, sy100, rot) end (* arc and circle *) (* ---------- LABELS --------------*) else if streq (nam.str, labelnam, 3) then begin i := findscale; SPscale := thescaleof (i); style := getnumber; (* font style number *) if ((style < 1) or (style > MAXLABELFONTS)) then begin complain (ERRBAD); writeln(logfile,'Label style bad? Setting to Style 1'); style := 1; end; x1 := round (getnumber * SPscale); y1 := round (getnumber * SPscale); let := getletter; while (let <> '"') do begin let := getletter; end; i := 0; let := getanything; (* get next letter or whatever *) while (let <> '"') do begin (* get the label phrase *) i := i + 1; phrase.str[i] := let; let := getanything; (* getletter;*) end; phrase.str[i+1] := chr(32); phrase.len := i; BackupInBuf (DVIMark - specstart); cmd1byte (OURFONTFLAG); labelhandle (multifigure, SPscale, x1, y1, 0, 0, style, phrase, 0, 0); end (* label *) (* --------- INTERNAL PARAM -------*) else if streq (nam.str, paramnam, 3) then begin i := getnumber; (* addressable param number *) begin writeln (logfile,' I do not know what internal parameter #',i:0,' is'); end; (* else *) BackupInBuf (DVIMark - (specstart)); end (* Internal param *) (* ============== NONE OF THE ABOVE ============== *) else begin complain (ERRNOTBAD); write (logfile,'Sorry, I don''t know how to tyl '); writestrng (nam,true); while (gotten < numpbytes) do begin b := nextpbyte; end; end; 888: (* make sure that we used up all the bytes in this special *) if (gotten < numpbytes) then begin while (gotten < numpbytes) do begin (* slurp up excess *) b := Dgrabbyte; gotten := gotten + 1; end; end; (* if *) end; (* mainhandlespecials *) (* ================================================== The routines below assume coordinates are already in 4th Quadrant DVI-space =====================================================*) {-----------------------------------------------------} (* returns 0 if dy.dx not in font 1 if ok 2 if ok and caller should use two of the "code"s coding scheme requires 0<= [dx, dy] <= 16 AND that max(dx, abs(dy)) is in [0,1,2,4,8,16] *) function outvector (dx, dy : integer; var code : integer) : integer; label 99; var c : integer; result : integer; begin if (dx < 0) then begin outvector := 0; goto 99; end; result := 0; (* init for potential failure *) code := (-1); if (dy < 0) then begin c := 160 + dy + dx - 9*max (dx, -dy); end else begin c := 160 + dy - dx - 7*max (dx, dy); end; (* here translate to OUR coding scheme and return the correct number this is needed because "c" thinks the char range is 0 to 160, while we have only 128 chars *) if (c = 0) then (* special cases *) begin code := 63; result := 2; end else if (c = 64) then begin code := 95; result := 2; end else begin (* regular ones *) result := 1; (* just one char is fine *) if (c in [1..63]) then code := c - 1 else if (c in [80..112]) then code := c - 17 else if (c in [120..136]) then code := c - 24 else if (c in [140..148]) then code := c - 27 else if (c in [150..154]) then code := c - 28 else if (c = 160) then code := 127; (* c - 33 *) end; 99: outvector := result; end; (* take care of a Manhattan (horizontal /vertical) line *) {----------------------------------------------------------} procedure hvline (lx, by, rx, ty, fontindex : integer); var t, rth, x, y, width, height : integer; begin rth := VFontTable[fontindex]^.PenSize; (* thickness of vector in sp *) if (lx = rx) then begin (* Vertical line *) if (ty > by) then begin t := by; by := ty; ty := t; (* swap *) end; x := round (lx - (rth / 2.0)); y := by; width := rth; height := by - ty; end else begin (* Horizontal line *) if (ty < by) then begin t := by; by := ty; ty := t; (* swap *) end; if (lx > rx) then begin t := lx; lx := rx; rx := t; (* swap *) end; x := lx; y := (by + (rth div 2)); (* + rth for {h,v}-space *) width := rx - lx; height := rth; end; isetpos (x, y); cmd1byte (PUTRULE); cmd4byte (height); cmd4byte (width); (* output two dots on ends of the rules at lx, by and rx, ty *) (* the font has already been set before these calls *) Tyldot (lx, by); Tyldot (rx, ty); isetpos (rx, ty); end; {------------------------------------------------------------} procedure diagonal (xl, yb, xr, yt : ScaledPts; fontindex: integer); var t, curx, cury, dx, dy, code : integer; slope : real; mxveclen : ScaledPts; sptovecs : real; rho : ScaledPts; {......................................} (* compute maximum length vector character that we can use *) procedure getincr (var outdx, outdy : integer); label 99; var radius, x, y : integer; sign : integer; q : real; begin (* getincr *) radius := mxveclen; (* radius of semi-square *) (* make sure the pt is outside of the semi-square, scaling down radius if necessary *) while ( ((xr - curx) < radius) and (abs (yt - cury) < radius)) do begin radius := radius div 2; end; if (slope < 0.0) then (* <0 since in 4th quad by now*) sign := -1 else sign := +1; if (xr = curx) then begin outdx := 0; outdy := sign * radius; goto 99; end; if (yt = cury) then begin outdx := abs (radius); outdy := 0; goto 99; end; (* compute the intersection with the semi-square, choose whichever slope is best *) if (abs (slope) < 1.0) then begin (* mostly horizontal *) outdx := abs (radius); y := yb + round ((curx + abs(radius) - xl) * slope); outdy := y - cury; end else begin (* mostly vertical *) x := xl + round ((cury + (sign * radius) - yb) / slope); outdx := x - curx; outdy := sign * radius; end; if (abs (outdy) > abs (yt - cury)) then begin (* truncate *) outdy := yt - cury; end; if (outdx > (xr - curx)) then begin (* truncate *) outdx := xr - curx; end; if (outdx < 0) then begin outdx := 0; end; (* method to find the exact intersection of the line segment with the semi-circle, used to determine the x and y values:: we do this by using the arctangent of the slope as the angle 'a' from the x-axis. Then use the relation y = r cos a, and x = r sin a we can be smart about all this trig stuff by using the relation : sin (arctan a) = 1/sqrt(1 + a^2) cos (arctan a) = a/sqrt(1 + a^2) Thus: q := (1.0 / sqrt (slope * slope + 1.0)); outdx := round (q * radius); outdy := round (q * radius * slope); Unfortunately, we cannot access the Vector Font coding scheme because the outdx, outdy 's produced here do no conform to the condition max (dx, abs(dy)) in [0,1,2,4,8,16] when converted to vector-font sizes with sptovecs (see the 'diagonal' proc.). *) 99: end; (* getincr *) {.......................................} begin (* DIAGONAL *) if (xr <> xl) then slope := (yt - yb) / (xr - xl) else slope := BIGREAL; (* some illegal value *) if (xl > xr) then begin t := xl; xl := xr; xr := t; t := yb; yb := yt; yt := t; end; (* swap *) curx := xl; cury := yb; mxveclen := (VFontTable[fontindex]^.MaxVectLen); rho := mxveclen div 16; (* minimum radius of vector fonts *) if (rho = 0) then begin complain (ERRREALBAD); writeln(logfile,'Diagonal: Min radius of vector font is zero. setting to 1'); rho := 1; end; if ((abs(xl - xr) <= rho) and (abs(yb - yt) <= rho)) then begin (* pretty much a null line *) Tyldot (xl, yb); end else begin sptovecs := 1.0 / rho; (* conversion for scaled pts to vectorfont units *) code := -1; (* initialize to a bogus number *) (* this conditional really has to have "or" instead of "and", because of lines that are *nearly* horizontal or vertical *) while (((xr - curx) >= rho) or (abs(yt - cury) >= rho)) do begin (* Get the approximate incremental amount. We use this dy/dx pair in order to index into our vector font coding scheme *) getincr (dx, dy); (* Get the vector character code corresponding to this approximate incremental amount *) t := outvector (round (dx * sptovecs), round (dy * sptovecs), code); (* Now that we have the character code, go find out its actual physical dimensions for the real dy/dx amounts *) if (dy > 0) then dy := VFontTable[fontindex]^.FontInfo[code].Cdp else dy := -(VFontTable[fontindex]^.FontInfo[code].Cht); dx := VFontTable[fontindex]^.FontInfo[code].Cwd; case (t) of 0: begin complain (ERRREALBAD); writeln (logfile,'Error in Diagonal:: bad dydx'); end; 1: begin isetpos (curx, cury); iputchar (code); end; 2: begin isetpos (curx, cury); iputchar (code); isetpos (curx + (dx div 2), cury + (dy div 2)); iputchar (code); end; end; (* case *) curx := curx + dx; cury := cury + dy; end; (* while *) if ((code >= 0) and (((xr - curx) >= rho) and (abs(yt - cury) >= rho))) then begin iputchar (code); end; end; (* not null line *) end; {-------------------------------------------------------} procedure tylBrokenLine (x0, y0, x1, y1, fontindex : integer; line_type: LineStyle); label 10; var useXaxis: boolean; a0, b0, a1, b1: integer; a2, a3, b2, b3, K, gap, dot, dash: integer; s, z, fit: real; J, frame, T: integer; Dotgap, Dotdot: integer; Dashgap, Dashdash: integer; DDotgap, DDotdot, DDotdash: integer; a1ma0 : integer; {.........................................................} procedure spread (lt : LineStyle; extra, T : integer); label 20; begin if (T = 0) then begin { only partial frame fits } if (useXaxis) then diagonal (a0, b0, a1, b1, fontindex) else diagonal (b0, a0, b1, a1, fontindex); goto 20; { exit } end; J := 0; s := float (b1 - b0)/float(a1 - a0); z := float (extra)/float(T); case lt of dotted : repeat a2 := a0 + J*frame; if (extra > 0) then a2 := a2 + round(J*z); a3 := a2 + dot; b2 := round(s*(a2-a0) + b0); b3 := round(s*(a3-a0) + b0); if (a3 <= a1) then begin if (useXaxis) then diagonal (a2, b2, a3, b3, fontindex) else diagonal (b2, a2, b3, a3, fontindex); end; J := J + 1; until (a3 >= a1); dashed : repeat a2 := a0 + J*frame; if (extra > 0) then a2 := a2 + round(J*z); a3 := a2 + dash; b2 := round(s*(a2-a0) + b0); b3 := round(s*(a3-a0) + b0); if (a3 <= a1) then begin if (useXaxis) then diagonal (a2, b2, a3, b3, fontindex) else diagonal (b2, a2, b3, a3, fontindex); end; J := J + 1; until (a3 >= a1); dotdash : repeat a2 := a0 + J*frame; if (extra > 0) then a2 := a2 + round(J*z); a3 := a2 + dash; b2 := round(s*(a2-a0) + b0); b3 := round(s*(a3-a0) + b0); if (a3 <= a1) then begin if (useXaxis) then diagonal (a2, b2, a3, b3, fontindex) else diagonal (b2, a2, b3, a3, fontindex); a2 := a3 + gap; if (extra > 0) then a2 := a2 + round(z*0.5); a3 := a2 + dot; b2 := round(s*(a2-a0) + b0); b3 := round(s*(a3-a0) + b0); if (a3 <= a1) then begin if (useXaxis) then diagonal (a2, b2, a3, b3, fontindex) else diagonal (b2, a2, b3, a3, fontindex); end; end; J := J + 1; until (a3 >= a1); end; 20: end; { spread } {......................................................} procedure balance (lt : LineStyle; extra, T : integer); label 30; begin if (T = 0) then begin { only partial frame fits } if (useXaxis) then diagonal (a0, b0, a1, b1, fontindex) else diagonal (b0, a0, b1, a1, fontindex); goto 30; { exit } end; J := 0; s := float(b1 - b0)/float(a1 - a0); case lt of dashed : repeat a2 := a0 + J*frame - extra div 2; a3 := a2 + dash; if (J = 0) then a2 := a0; if (a3 > a1) then a3 := a1; b2 := round(s*(a2-a0) + b0); b3 := round(s*(a3-a0) + b0); if (a3 <= a1) then begin if (useXaxis) then diagonal (a2, b2, a3, b3, fontindex) else diagonal (b2, a2, b3, a3, fontindex); end; J := J + 1; until (a3 >= a1); dotdash : repeat a2 := a0 + J*frame - extra div 2; a3 := a2 + dash; if (J = 0) then a2 := a0; if (a3 > a1) then a3 := a1; b2 := round(s*(a2-a0) + b0); b3 := round(s*(a3-a0) + b0); if (a3 <= a1) then begin if (useXaxis) then diagonal (a2, b2, a3, b3, fontindex) else diagonal (b2, a2, b3, a3, fontindex); a2 := a3 + gap; a3 := a2 + dot; b2 := round(s*(a2-a0) + b0); b3 := round(s*(a3-a0) + b0); if (a3 <= a1) then begin if (useXaxis) then diagonal (a2, b2, a3, b3, fontindex) else diagonal (b2, a2, b3, a3, fontindex); end; end; J := J + 1; until (a3 >= a1); end; 30: end; { balance } {......................................................} function project (I : integer) : integer; var K : integer; { gives the projection of lengths onto axes } begin K := round(I*float(abs(a1-a0))/s); if K = 0 then K := 1; project := K; end; {......................................................} procedure setlengths (findex :integer); (* sets the "optimal" sizes for textured lines *) var penrad : integer; siz : VThickness; begin penrad := VFontTable[findex]^.PenSize; siz := VFontTable[findex]^.psize; Dotdot := penrad div siz; Dotgap := 6 * penrad; Dashdash := 6 * penrad; Dashgap := 6 * penrad; DDotdash := 6 * penrad; DDotgap := 4 * penrad; DDotdot := penrad div siz; end; {........................................} procedure setframesize; begin case line_type of { length of frame depends on type of broken line } solid : frame := 0; dotted : frame := gap + dot; dashed : frame := gap + dash; dotdash : frame := 2*gap + dot + dash; end; end; {.................................................} begin (* TylBrokenLine *) if ((x0 = x1) and (y0 = y1)) then begin diagonal (x0, y0, x1, y1, fontindex); { null line } goto 10; end; setlengths (fontindex); if (abs (y1-y0) > abs(x1-x0)) then { longer axis is used as base } begin useXaxis := false; a0 := y0; b0 := x0; a1 := y1; b1 := x1; end else begin useXaxis := true; a0 := x0; b0 := y0; a1 := x1; b1 := y1; end; { the distance between a0 and a1 is now greater than that between b0 and b1. } { redefine distances as integral units along axes } s := distance (float(a0),float(b0),float(a1),float(b1)); case line_type of solid: ; dotted: begin gap := project(Dotgap); dot := project(Dotdot); end; dashed: begin gap := project(Dashgap); dash := project(Dashdash); end; dotdash: begin gap := project(DDotgap); dot := project(DDotdot); dash := project(DDotdash); end; end; { ensure direction of line is from smaller to larger along the longer axis } if (a0 > a1) then begin J := a0; a0 := a1; a1 := J; J := b0; b0 := b1; b1 := J; end; setframesize; a1ma0 := a1 - a0; { fit is the number of frames that fit in line } if (frame <> 0) then begin fit := (float(a1ma0) / float(frame)); end else fit := 1.0; if (fit >= 1.0) then T := round (fit) else begin (* change frame elements (dot, dash, gap) since frame is too large *) case line_type of dotted : begin gap := gap - (frame - a1ma0); if (gap < dot) then begin goto 10; (* exit *) end; setframesize; end; dashed, dotdash : begin (* idea:decrease gap; if too small then shrink dash and refigure gap*) if ((frame - a1ma0) > (gap div 2)) then begin dash := round (dash * fit * 0.80); gap := round (gap * fit); setframesize; end; gap := gap - (frame - a1ma0); if (line_type = dotdash) then gap := gap div 2; if (gap < dot) then begin goto 10; (* exit *) end; setframesize; end; end; (* case *) T := 1; (* NOW it will fit *) end; (* else *) case line_type of solid : begin if (useXaxis) then diagonal (a0, b0, a1, b1, fontindex) else diagonal (b0, a0, b1, a1, fontindex); end; dotted : begin { dotted lines begin and end on a dot } if ((T*frame + dot) = a1ma0) then spread(dotted, 0, T) else if ((T*frame + dot) > a1ma0) then begin { gap := gap - ((T*frame+dot)-a1ma0); {} spread(dotted, a1ma0 - T*frame - dot, T); { spread(dotted, a1ma0 - (T-1)*frame - dot, T-1); {} end else spread(dotted, a1ma0 - T*frame - dot, T); end; dashed : begin { dashed lines begin and end on dash : the beginning and ending dashes are at least half the dash length long. } if ((T*frame + dash) = a1ma0) then spread(dashed, 0, T) else if ((T*frame + dash) > a1ma0) then balance(dashed, T*frame + dash - a1ma0, T) else spread(dashed, a1ma0 - T*frame - dash, T); end; dotdash : begin { if ending on a dash then beginning and ending dashes are half the dash length long - final dots are full dot length } if ((T*frame + dash) = a1ma0) then spread(dotdash, 0, T) else if ((T*frame + dash + gap + dot) = a1ma0) then spread(dotdash, 0, T) else if ((T*frame + dash) > a1ma0) then balance(dotdash, T*frame + dash - a1ma0, T) else if ((T*frame + dash + gap + dot) > a1ma0) then spread(dotdash, a1ma0 - T*frame - dash, T) else spread(dotdash, a1ma0 - T*frame - dash - gap - dot, T); end; end; 10: end; {-------------------------------------------------------} procedure clampthickness (var thic : VThickness); begin (* #### this is just a simple clamp really should be something like: while not (thic in set_of_appropriate_thicknesses) do modify thic and try again *) if (thic <= LoVThick ) then thic := LoVThick + 1; while ((not (thic in [1,2,3,4,5,6,7,8,9,10,11,12])) and (thic <= HiVThick)) do thic := thic + 1; if (thic > HiVThick) then thic := HiVThick; end; {----------------------------------------------------------} procedure slurclamp (var thic : ThickAryType; totpts : integer); (* this post-clamps the sampled thicknesses calculated over the whole of the spline *) var i : integer; oneseventh : integer; middle : integer; startval, endval: integer; deltaval, val, incrval, alpha, alphaincr: real; begin { $$ NOTE:: How does the ttspline interpolation of thicknesses compare to the below results?? Can we avoid having it done elsewhere and concentrate on it here?? } oneseventh := round (totpts / 7.0); for i := 1 to oneseventh do begin thic[i] := thic[1]; end; for i := 6*oneseventh to totpts do begin thic[i] := thic[totpts]; end; middle := round (totpts / 2.0); for i := 3*oneseventh to 4*oneseventh do begin thic[i] := thic[middle]; end; startval := thic[oneseventh - 1]; endval := thic[3*oneseventh + 1]; deltaval := (2*(endval - startval))/(2*oneseventh); alphaincr := PI / (2 * oneseventh + 1); alpha := PI; val := float(startval); for i := oneseventh to (3*oneseventh - 1) do begin (* interpolate: ease in from minthick to middlethickness *) alpha := alpha + alphaincr; incrval := ((cos (alpha) + 1.0) / 2.0) * deltaval; val := val + incrval; thic[i] := round(val); end; startval := thic[4*oneseventh - 1]; endval := thic[6*oneseventh + 1]; deltaval := (2*(endval - startval))/(2*oneseventh); alphaincr := PI / (2 * oneseventh + 1); alpha := 0.0; val := float(startval); for i := (4*oneseventh + 1) to 6*oneseventh do begin (* ease out from middle thickness to min thick at far end *) alpha := alpha + alphaincr; incrval := ((cos (alpha) + 1.0) / 2.0) * deltaval; val := val + incrval; thic[i] := round(val); end; end; {-------------------------------------------------------} procedure layline (xl, yb, xr, yt, fontindex : integer; pattern : LineStyle; useVecfontOnly : boolean); var t: integer; begin if (xr < xl) then begin t := xr; xr := xl; xl := t; t := yb; yb := yt; yt := t; end; isetfont (VFontTable[fontindex]^.DVIFontNum); (* we may want to require using a vector font only, instead of a combination of vectors and TeX-rules. It may look better this way. *) if (useVecfontOnly) then begin tylBrokenLine (xl, yb, xr, yt, fontindex, pattern); end else begin (* be smart about the lines *) if ((xl = xr) and (yb = yt)) or ((xl <> xr) and (yb <> yt)) then (* Null or diagonal lines *) begin if (pattern = solid) then diagonal (xl, yb, xr, yt, fontindex) else tylBrokenLine (xl, yb, xr, yt, fontindex, pattern); end else begin { if (pattern = solid) then hvline (xl, yb, xr, yt, fontindex) (* make use of rules *) else USENORULES } tylBrokenLine (xl, yb, xr, yt, fontindex, pattern); end end; end; {------------------------------------------------------} procedure layAspline (thetype : SplineKind; isclosed : boolean; isanArc: boolean; domarks : integer; var cpts : ControlPoints; numpts : integer; thick: VThickness; vkind : VectKind; patt : LineStyle); const DontDoThicks = false; VectorsOnly = true; var pointList: SplineSegments; i, xs, ys : integer; tt1, tt2 : ThickAryType; F: VecIndex; begin clampthickness (thick); for i := 0 to (numpts + 3) do tt1[i] := thick; (* do any marks if necessary to show the control points *) if (domarks > 0) then begin F := GetVectFont (domarks, VKCirc); isetfont (VFontTable[F]^.DVIFontNum); for i := 1 to numpts do begin Tyldot (cpts[i,1], cpts[i,2]); end; end; drawSpline (thetype, isclosed, isanArc, patt, numpts, cpts, pointList, DontDoThicks, tt1, tt2); F := GetVectFont (thick, vkind); xs := pointList[1, 1]; ys := pointList[1, 2]; for i := 2 to lastPoint do begin layline (xs, ys, pointList[i, 1], pointList[i, 2], F, patt, VectorsOnly); xs := pointList[i, 1]; ys := pointList[i, 2]; end; if (isclosed) then (* complete the motion *) layline (pointList[lastPoint,1], pointList[lastPoint,2], pointList[1,1], pointList[1,2], F, patt, VectorsOnly); end; {-----------------------------------------------------} procedure layNspline (thetype : SplineKind; isclosed : boolean; isitaslur : boolean; domarks : integer; var cpts : ControlPoints; numpts : integer; var thickmatrix : ThickAryType; vkind : VectKind; patt : LineStyle); const NotAnArc = false; DoThicksToo = true; VectorsOnly = true; var pointList: SplineSegments; i, xs, ys : integer; ts : VThickness; tt : ThickAryType; F : VecIndex; begin (* do any marks if necessary to show the control points *) if (domarks > 0) then begin F := GetVectFont (domarks, VKCirc); isetfont (VFontTable[F]^.DVIFontNum); for i := 1 to numpts do begin Tyldot (cpts[i,1], cpts[i,2]); end; end; drawSpline (thetype, isclosed, NotAnArc, patt, numpts, cpts, pointList, DoThicksToo, thickmatrix, tt); if ((isitaslur) and (not skiptsclamp)) then begin slurclamp(tt, lastPoint); (* which kind of clamping to use *) end; xs := pointList[1, 1]; ys := pointList[1, 2]; ts := tt[1]; for i := 2 to lastPoint do begin clampthickness (ts); F := GetVectFont (ts, vkind); layline (xs, ys, pointList[i, 1], pointList[i, 2], F, patt, VectorsOnly); xs := pointList[i, 1]; ys := pointList[i, 2]; ts := tt[i]; end; if (isclosed) then begin ts := tt[lastPoint]; clampthickness(ts); F := GetVectFont (ts, vkind); layline (pointList[lastPoint,1], pointList[lastPoint,2], pointList[1,1], pointList[1,2], F, patt, VectorsOnly); end; end; {-----------------------------------------------------} procedure TylBeam (* fromx, fromy, tox, toy: ScaledPts; staffsize : integer; kind : BeamKind *); begin end; (* TylBeam *) {-------------------------------------------------------} procedure TylLine (* xl, yb, xr, yt: ScaledPoints; thickness: VThickness; vec: VectKind; patt : LineStyle *); const dontCare = false; var findex: VecIndex; begin clampthickness (thickness); findex := GetVectFont (thickness, vec); layline (xl, yb, xr, yt, findex, patt, dontCare); end; {-----------------------------------------------------} procedure TylThickThinSpline (* thetype : SplineKind; isclosed : boolean; var KnotArray: ControlPoints; var ThikThinAry: ThickAryType; numknots: integer; vec: VectKind; patt : LineStyle; domarks : integer *); const NotAnArc = false; begin layNspline (thetype, isclosed, NotAnArc, domarks, KnotArray, numknots, ThikThinAry, vec, patt); end; {----------------------------------------------------} procedure TylSpline (* thetype : SplineKind; isclosed : boolean; var KnotArray: ControlPoints; numknots: integer; thick: VThickness; vec: VectKind; patt : LineStyle; domarks : integer*); const NotAnArc = false; begin layAspline (thetype, isclosed, NotAnArc, domarks, KnotArray, numknots, thick, vec, patt); end; {-----------------------------------------------------} procedure TylTieSlur (* KnotArray: ControlPoints; numknots: integer; minthick, maxthick: VThickness *); const ItsASlur = true; NotClosed = false; var ourttarray : ThickAryType; one7th : real; val : VThickness; begin clampthickness (minthick); clampthickness (maxthick); if (numknots <> 5) then writeln ('TieSlur needs 5 control points '); one7th := 1.0/7.0; val := round (one7th * (maxthick - minthick)); ourttarray[1] := minthick; ourttarray[2] := minthick + val; ourttarray[3] := maxthick; ourttarray[4] := minthick + val; ourttarray[5] := minthick; layNspline (CATROM, NotClosed, ItsASlur, 0, KnotArray, numknots, ourttarray, VKCirc, solid); end; {-------------------------------------------------------} procedure doTylArc (* iscircle : boolean; var apts : ControlPoints; numknots : integer; thick : VThickness; vec : VectKind; patt : LineStyle *); const ItsAnArc = true; begin layAspline (BSPL, iscircle, ItsAnArc, 0, apts, numknots, thick, vec, patt); end; {-----------------------------------------------------------} procedure TylArc (* radius : ScaledPts; centx, centy : ScaledPts; firstangle, secondangle : integer; thick : VThickness; vec : VectKind; patt : LineStyle *); var apts : ControlPoints; numknots : integer; iscircle : boolean; begin iscircle := (firstangle = secondangle); if iscircle then begin { maxspan := round ((360.0 / 16.0) * DEGTORAD * radius); {} defineCircleCpts (radius, centx, centy, apts, numknots); end else begin { maxspan := round ((abs (secondangle - firstangle) / 16.0) * DEGTORAD * radius); { } definearcpts (radius, centx, centy, firstangle, secondangle, apts, numknots); end; doTylArc (iscircle, apts, numknots, thick, vec, patt); end; {-----------------------------------------------------------} procedure TylLabel (* xpos, ypos : ScaledPts; fontstyle : integer; phrase : charstring; phraselen : integer *); var findex : integer; c : integer; spaceover : integer; begin if ((fontstyle < 1) or (fontstyle > MAXLABELFONTS)) then begin complain (ERRREALBAD); writeln(logfile,'Unexpected bad fontstyle in TylLabel: ',fontstyle:0,'?'); jumpout; end; findex := GetLabFont (fontstyle); isetpos (xpos, ypos); IPUSH; isetfont (LFontTable[findex]^.DVIFontNum); spaceover := LFontTable[findex]^.spacewidth; for c := 1 to phraselen do begin if (phrase[c] <> xchr[32]) then begin cmd1byte (SET1); cmd1byte (xord[ phrase[ c ]]); end else begin (* move over *) cmd1byte (RIGHTLEFT + 2); (* assume distance is less than 3 bytes *) cmdSigned (spaceover, 3); end; end; IPOP; end; (* && start dvidvi section *) {-----------------------------------------------------} procedure initialize; var i: integer; begin for i := 0 to 31 do xchr[i] := '?'; xchr[32] := ' '; xchr[33] := '!'; xchr[34] := '"'; xchr[35] := '#'; xchr[36] := '$'; xchr[37] := '%'; xchr[38] := '&'; xchr[39] := ''''; xchr[40] := '('; xchr[41] := ')'; xchr[42] := '*'; xchr[43] := '+'; xchr[44] := ','; xchr[45] := '-'; xchr[46] := '.'; xchr[47] := '/'; xchr[48] := '0'; xchr[49] := '1'; xchr[50] := '2'; xchr[51] := '3'; xchr[52] := '4'; xchr[53] := '5'; xchr[54] := '6'; xchr[55] := '7'; xchr[56] := '8'; xchr[57] := '9'; xchr[58] := ':'; xchr[59] := ';'; xchr[60] := '<'; xchr[61] := '='; xchr[62] := '>'; xchr[63] := '?'; xchr[64] := '@'; xchr[65] := 'A'; xchr[66] := 'B'; xchr[67] := 'C'; xchr[68] := 'D'; xchr[69] := 'E'; xchr[70] := 'F'; xchr[71] := 'G'; xchr[72] := 'H'; xchr[73] := 'I'; xchr[74] := 'J'; xchr[75] := 'K'; xchr[76] := 'L'; xchr[77] := 'M'; xchr[78] := 'N'; xchr[79] := 'O'; xchr[80] := 'P'; xchr[81] := 'Q'; xchr[82] := 'R'; xchr[83] := 'S'; xchr[84] := 'T'; xchr[85] := 'U'; xchr[86] := 'V'; xchr[87] := 'W'; xchr[88] := 'X'; xchr[89] := 'Y'; xchr[90] := 'Z'; xchr[91] := '['; xchr[92] := '\'; xchr[93] := ']'; xchr[94] := '^'; xchr[95] := '_'; xchr[96] := '`'; xchr[97] := 'a'; xchr[98] := 'b'; xchr[99] := 'c'; xchr[100] := 'd'; xchr[101] := 'e'; xchr[102] := 'f'; xchr[103] := 'g'; xchr[104] := 'h'; xchr[105] := 'i'; xchr[106] := 'j'; xchr[107] := 'k'; xchr[108] := 'l'; xchr[109] := 'm'; xchr[110] := 'n'; xchr[111] := 'o'; xchr[112] := 'p'; xchr[113] := 'q'; xchr[114] := 'r'; xchr[115] := 's'; xchr[116] := 't'; xchr[117] := 'u'; xchr[118] := 'v'; xchr[119] := 'w'; xchr[120] := 'x'; xchr[121] := 'y'; xchr[122] := 'z'; xchr[123] := '{'; xchr[124] := '|'; xchr[125] := '}'; xchr[126] := '~'; for i := 127 to 255 do xchr[i] := '?'; for i := 0 to 127 do xord[chr(i)] := 32; for i := 32 to 126 do xord[xchr[i]] := i; initallspline; initVnMnLtables; multifigure := 0; pgfigurenum := 0; TotBytesWritten := 0; ourq := 0; specstart := 0; currpagenum := 0; newbackptr := (-1); oldbackptr := (-1); ourfontnum := (-1); (* undefined *) origTexfont := (-1); ourpushdepth := 0; FTBDs := 0; InitDVIBuf; nf := 0; inpostamble := false; didnewfonts := false; maxpages := 10000; sysdependent; s := 0; skiptsclamp := false; ErrorOccurred := false; end; procedure inputln (var buffer : strng); var k: 0..ARRLIMIT; begin flush(output); if eoln(input) then readln(input); k := 1; while (k < ARRLIMIT) and (not eoln(input)) do begin buffer.str[k] := input^; k := k + 1; get(input) end; buffer.str[k] := ' '; buffer.len := k - 1; end; function revindex (st : strng; let : char) : integer; label 2; var posit,i : integer; begin posit := 0; for i := st.len downto 1 do begin if (st.str[i] = let) then begin posit := i; goto 2; end; end; 2: revindex := posit; end; procedure stripblanks (var st : strng); var i,j,k: integer; temp : charstring; begin j := 1; i := 1; while ((i <= st.len) and ((st.str[i] = ' ') or (st.str[i] = xchr[HT]))) do begin j := j + 1; i := i + 1; end; (* j now points to the first non-blank character in st.str *) i := 1; for k := j to st.len do begin if ((st.str[k] <> ' ') and (st.str[k] <> xchr[HT])) then begin temp[i] := st.str[k]; i := i + 1; end; end; (* now copy it back *) if (i <> 1) then begin (* there was blankspace *) for k := 1 to (i- 1) do st.str[k] := temp[k]; st.len := i - 1; st.str[i] := chr(32); (* end of string *) end; end; {-----------------------------------------------------} procedure AskandOpenFiles; var isok : boolean; i : integer; rp : integer; tempname : strng; begin isok := false; while (not isok) do begin write (' DVI-input File Name: '); inputln (dvifname); stripblanks (dvifname); rp := revindex (dvifname, '.'); if (rp = 0) then begin (* add a ".dvi" extension *) i := dvifname.len; dvifname.str[i + 1] := '.'; dvifname.str[i + 2] := 'd'; dvifname.str[i + 3] := 'v'; dvifname.str[i + 4] := 'i'; dvifname.len := i + 4; end; if (not opendvifile) then begin isok := false; (* it is empty *) writestrng(dvifname,false); writeln(': Empty File?? Try another name.'); end else isok := true; end; (* while *) (* and ask for the name of the output file *) (* default it to be the same prefix, but with a ".tyl" suffix *) strcopy (dvifname.str, outname.str, dvifname.len); outname.len := dvifname.len; rp := revindex (outname, '.'); i := rp - 1; outname.str[i + 1] := '.'; outname.str[i + 2] := 't'; outname.str[i + 3] := 'y'; outname.str[i + 4] := 'l'; outname.len := i + 4; writeln (' DVI-output File Name :'); write('(different than input name)[default of '); writestrng (outname,false); write(']'); inputln (tempname); if (tempname.len > 1) then begin (* a filename was typed in *) strcopy (tempname.str, outname.str, tempname.len); end; openoutputfile; strcopy (dvifname.str, logfilnam.str, dvifname.len); logfilnam.len := dvifname.len; rp := revindex (logfilnam, '.'); (* add a ".tlog" extension *) i := rp - 1; logfilnam.str[i + 1] := '.'; logfilnam.str[i + 2] := 't'; logfilnam.str[i + 3] := 'l'; logfilnam.str[i + 4] := 'o'; logfilnam.str[i + 5] := 'g'; logfilnam.len := i + 5; openlogfile; end; {-----------------------------------------------------} function inTFM (z: integer): boolean; label 9997, 9998, 9999; var k: integer; lh: integer; nw: integer; alpha, beta: integer; begin readtfmword; lh := b2 * 256 + b3; readtfmword; font[nf].bc := b0 * 256 + b1; font[nf].ec := b2 * 256 + b3; if (font[nf].ec < font[nf].bc) then font[nf].bc := font[nf].ec + 1; readtfmword; nw := b0 * 256 + b1; if ((nw = 0) or (nw > 256)) then goto 9997; for k := 1 to 3 + lh do begin if eof(tfmfile) then goto 9997; readtfmword; if (k = 4) then if (b0 < 128) then tfmchecksum := ((b0 * 256 + b1) * 256 + b2) * 256 + b3 else tfmchecksum := (((b0 - 256) * 256 + b1) * 256 + b2) * 256 + b3 end; for k := 0 to (font[nf].ec - font[nf].bc) do begin readtfmword; if (b0 > nw) then goto 9997; font[nf].widths[k] := b0 end; alpha := 16 * z; beta := 16; while z >= TWO23 do begin z := z div 2; beta := beta div 2 end; for k := 0 to nw - 1 do begin readtfmword; inwidth[k] := (((b3 * z) div 256 + b2 * z) div 256 + b1 * z) div beta; if b0 > 0 then if b0 < 255 then goto 9997 else inwidth[k] := inwidth[k] - alpha; end; if inwidth[0] <> 0 then goto 9997; with font[nf] do begin for k := 0 to (ec - bc) do if widths[k] = 0 then begin widths[k + bc] := TWO31; { pixelwidths[k + bc] := 0;} end else begin widths[k + bc] := inwidth[widths[k]]; { pixelwidths[k + bc] := round(conv * widths[k]);} end; end; (* with *) inTFM := true; goto 9999; 9997: complain (ERRREALBAD); writestrng(tfmname,true); writeln(logfile,'---not loaded, TFM file is bad'); 9998: inTFM := false; 9999: end; {-----------------------------------------------------} procedure Fastdefinefont (fn: integer); var p, k: integer; n, waste: integer; c, q, d: integer; begin { Fastdefinefont } c := Dsign4byte; q := Dsign4byte; d := Dsign4byte; p := Dget1byte; n := Dget1byte; for k := 1 to (p + n) do waste := Dget1byte; end; { Fastdefinefont } {-----------------------------------------------------} procedure definefont (e: integer); var f: 0..MAXFONTS; p, k: integer; n: integer; c, q, d: integer; r: integer; begin if (nf = MAXFONTS) then begin complain (ERRREALBAD); writeln(logfile,'TeXtyl capacity exceeded (max fonts=', MAXFONTS: 1, ')!'); writeln('TeXtyl capacity exceeded (max fonts=', MAXFONTS: 1, ')!'); jumpout end; font[nf].num := e; f := 0; while font[f].num <> e do (* find first occurrence *) f := f + 1; c := Dsign4byte; font[nf].checksum := c; q := Dsign4byte; font[nf].scaledsize := q; d := Dsign4byte; font[nf].designsize := d; p := Dget1byte; n := Dget1byte; font[nf].name.len := p + n; for k := 1 to (p + n) do font[nf].name.str[k] := Dget1byte; if (f = nf) then begin (* f = nf *) for k := 1 to AREALENGTH do tfmname.str[k] := ' '; r := 0; for k := 1 to font[nf].name.len do begin r := r + 1; tfmname.str[r] := xchr[font[nf].name.str[k]] end; tfmname.str[r + 1] := '.'; tfmname.str[r + 2] := 't'; tfmname.str[r + 3] := 'f'; tfmname.str[r + 4] := 'm'; tfmname.str[r + 5] := chr(32); tfmname.len := r + 4; if (not opentfmfile) then begin complain (ERRREALBAD); writestrng(tfmname,true); writeln(logfile,'---not loaded, TFM file can''t be opened!'); writestrng(tfmname, false); writeln(' cannot be opened. Aborting.'); jumpout; end else begin if (q <= 0) or (q >= TWO27) then begin complain (ERRREALBAD); writestrng(tfmname,true); writeln(logfile,'---not loaded, bad scale (', q: 1, ')!'); end else if (d <= 0) or (d >= TWO27) then begin complain (ERRREALBAD); writestrng(tfmname,true); writeln(logfile,'---not loaded, bad design size (', d: 1, ')!'); end else if inTFM(q) then begin (* intfm *) font[nf].space := q div 6; if (c <> 0) and (tfmchecksum <> 0) and (c <> tfmchecksum) then begin writeln(logfile,'Problem in fig#',pgfigurenum:0,' on page ',currpagenum:0); writestrng(tfmname,true); writeln(logfile,'---beware: check sums do not agree!'); writeln(logfile,' (', c: 1, ' vs. ', tfmchecksum: 1, ')'); end; d := round(100.0 * conv * q / (trueconv * d)); nf := nf + 1; font[nf].space := 0; end (* intfm *) end; end; end; {-----------------------------------------------------} function firstpar (o: OctByt): integer; var fpar : integer; begin case (o) of 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127: fpar := o - 0; 128, 133, 235, 239, 243: fpar := Dget1byte; 129, 134, 236, 240, 244: fpar := Dget2byte; 130, 135, 237, 241, 245: fpar := Dget3byte; 143, 148, 153, 157, 162, 167: fpar := Dsign1byte; 144, 149, 154, 158, 163, 168: fpar := Dsign2byte; 145, 150, 155, 159, 164, 169: fpar := Dsign3byte; 131, 132, 136, 137, 146, 151, 156, 160, 165, 170, 238, 242, 246: fpar := Dsign4byte; 138, 139, 140, 141, 142, 247, 248, 249, 250, 251, 252, 253, 254, 255: fpar := 0; 147: fpar := w; 152: fpar := x; 161: fpar := y; 166: fpar := z; 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234: fpar := o - 171 end; firstpar := fpar; end; {-----------------------------------------------------} function specialcases (o: OctByt; p: integer): boolean; label 46, 44, 30, 9998; var pure: boolean; begin pure := true; if ((o < 157) or (o > 249)) then begin complain (ERRREALBAD); writeln(logfile, 'undefined command ', o: 1, '!'); goto 30; end; case (o) of 157, 158, 159, 160: begin goto 44; end; 161, 162, 163, 164, 165: begin y := p; goto 44; end; 166, 167, 168, 169, 170: begin z := p; goto 44; end; 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234: begin goto 46; end; 235, 236, 237, 238: begin goto 46; end; 243, 244, 245, 246: begin definefont(p); goto 30; end; 239, 240, 241, 242: begin (* =========specials============= *) mainhandlespecials (o, p); goto 30; end; 247: begin complain (ERRREALBAD); writeln(logfile,'preamble command within a page!'); goto 9998; end; 248, 249: begin complain (ERRREALBAD); writeln(logfile,'postamble command within a page!'); goto 9998; end; (* others: begin write(' ', 'undefined command ', o: 1, '!'); goto 30; end *) end; 44: (* label *) if (v > 0) and (p > 0) then if (v > TWO31 - p) then begin p := TWO31 - v end; if (v < 0) and (p < 0) then if ((-v) > (p + TWO31)) then begin p := -v - TWO31 end; v := v + p; goto 30; 46: (* label *) font[nf].num := p; curfont := 0; while font[curfont].num <> p do curfont := curfont + 1; goto 30 ; 9998: pure := false; 30: specialcases := pure; end; {-----------------------------------------------------} function dopage : boolean; label 41, 42, 43, 30, 9998, 9999; var o: OctByt; p, q: integer; begin curfont := nf; s := 0; h := 0; v := 0; w := 0; x := 0; y := 0; z := 0; ourxpos := 0; ourypos := 0; ourfontnum := (-1); while true do begin o := Dget1byte; p := firstpar(o); if eof(dvifile) then begin writeln(logfile, 'Bad DVI file: ', 'the file ended prematurely', '!'); writeln('Bad DVI file: ', 'the file ended prematurely', '!'); jumpout end; if o <= 131 then begin goto 41; end else begin if (o > 156) then begin if specialcases(o, p) then goto 30 else goto 9998; end; case (o) of 133, 134, 135, 136: begin goto 41; end; 132, 137: begin goto 42 end; 138: begin goto 30; end; 139: begin (* BOP *) complain (ERRREALBAD); writeln(logfile, 'bop occurred before eop'); goto 9998; (* Fail *) end; 140: begin (* EOP *) if (s <> 0) then begin complain (ERRREALBAD); writeln(logfile, 'stack not empty at end of page (level ', s: 1, ')!'); end; if (multifigure <> 0) then begin complain (ERRBAD); writeln(logfile,'Some figure definition not closed at end of page ', currpagenum:0,'!'); end; write (currpagenum:0,']'); write (logfile,currpagenum:0,']'); if ((currpagenum mod 10) = 0) then writeln; dopage := true; goto 9999; end; 141: begin (* PUSH *) with stack[s] do begin sh := h; sv := v; sw := w; sx := x; sy := y; sz := z; end; (* with *) s := s + 1; goto 30; end; 142: begin (* POP *) if s = 0 then begin complain (ERRREALBAD); writeln(logfile,'illegal pop at level zero!'); end else begin s := s - 1; with stack[s] do begin h := sh; v := sv; w := sw; x := sx; y := sy; z := sz; end; end; goto 30; end; 143, 144, 145, 146: begin q := p; goto 43 end; 147, 148, 149, 150, 151: begin w := p; q := p; goto 43 end; 152, 153, 154, 155, 156: begin x := p; q := p; goto 43 end; (* others: if specialcases(o, p) then goto 30 else goto 9998; *) end; (* case *) end; (* else *) 41: (* finish cmd to set/put a char *) if p < 0 then p := 255 - (-1 - p) mod 256 else if p >= 256 then p := p mod 256; if (p < font[curfont].bc) or (p > font[curfont].ec) then q := TWO31 else q := font[curfont].widths[p]; if (q = TWO31) then begin complain (ERRREALBAD); writeln(logfile,'Character ', p:1,' invalid in font #',curfont:0); end; if o >= 133 then goto 30; if q = TWO31 then q := 0; goto 43; 42: (* finish cmd to set/put rule *) q := Dsign4byte; if o = 137 then goto 30; goto 43 ; 43: (*finish cmd that sets h += q *) if (h > 0) and (q > 0) then if (h > (TWO31 - q)) then begin q := TWO31 - h end; if (h < 0) and (q < 0) then if ((-h) > (q + TWO31)) then begin q := (-h) - TWO31 end; h := h + q; 30: end; 9998: dopage := false; 9999: end; {-----------------------------------------------------} procedure skippages; label 9999; var p: integer; k: 0..255; downthedrain: integer; begin while true do begin if eof(dvifile) then begin writeln(logfile, 'Bad DVI file: ', 'the file ended prematurely', '!'); write(' ', 'Bad DVI file: ', 'the file ended prematurely', '!'); jumpout end; k := Dget1byte; p := firstpar(k); case (k) of 139: begin (* BOP *) newbackptr := DVIMark + TotBytesWritten - 1; currpagenum := Dsign4byte; (* count[0] *) for k := 1 to 9 do waste := Dsign4byte; (* WAS count[k] := *) downthedrain := Dsign4byte; BackupInBuf (4); cmdSigned (oldbackptr, 4); oldbackptr := newbackptr; write(' ['); write(logfile,' ['); goto 9999; end; 132, 137: (* RULE *) downthedrain := Dsign4byte; 243, 244, 245, 246: begin definefont(p); end; 239, 240, 241, 242: (* specials *) begin mainhandlespecials (k, p); end; 248: begin (* POST *) ourq := DVIMark + TotBytesWritten - 1; inpostamble := true; goto 9999 end; (* others: null *) end end; 9999: end; {-----------------------------------------------------} procedure readpostamble; var k: integer; p, q, m: integer; indx : integer; begin if (Dsign4byte <> numerator) then writeln(logfile,'Postamble',' numerator',' doesn''t match the preamble!'); if (Dsign4byte <> denominator) then writeln(logfile,'Postamble',' denominator',' doesn''t match the preamble!'); if (Dsign4byte <> mag) then begin writeln(logfile,'Postamble',' magnification',' doesn''t match the preamble!'); end; maxv := Dsign4byte; maxh := Dsign4byte; maxs := Dget2byte; BackupInBuf (2); cmd2byte (maxs + 2); (* pretend the stack depth * does not increase by * more than two *) totalpages := Dget2byte; repeat k := Dget1byte; if (k >= 243) and (k < 247) then begin p := firstpar(k); Fastdefinefont(p); k := 138; end until k <> 138; (* NOP *) (* here, backup 1, enter all our fonts and then output the 249 that we backed over *) BackupInBuf (1); for indx := 1 to MFontsDefd do begin with MFontTable[indx]^ do enterfont (DVIFontNum, Cksum, DesSize, DesSize, FontName ); end; (* for *) for indx := 1 to VFontsDefd do begin with VFontTable[indx]^ do enterfont (DVIFontNum, Cksum, DesSize, DesSize, FontName); end; (* for *) for indx := 1 to LFontsDefd do begin with LFontTable[indx]^ do enterfont (DVIFontNum, Cksum, DesSize, DesSize, FontName); end; cmd1byte(249); (* post post *) if (k <> 249) then writeln(logfile,'byte ',k:0,' is not postpost!'); q := Dsign4byte; BackupInBuf (4); cmd4byte (ourq); m := Dget1byte; if (m <> 2) then writeln(logfile,'identification should be ', 2: 1, '!'); m := 223; while (m = 223) and not eof(dvifile) do m := Dget1byte; if not eof(dvifile) then begin writeln(' ', 'Bad DVI file: ', 'signature in should be 223', '!'); writeln(logfile, 'Bad DVI file: ', 'signature in should be 223', '!'); jumpout end; end; (* MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN *) begin (* main *) initialize; AskandOpenFiles; (* ask for filenames of inputdvi and outputfil *) writeln(logfile, TylVersion,' for Berkeley Unix'); write(logfile,'Reading File: '); writestrng(dvifname,true); writeln(logfile); p := Dget1byte; if (p <> 247) then begin write(' ', 'Bad DVI file: ', 'First byte isn''t start of preamble!', '!'); writeln(logfile,'Bad DVI file: ', 'First byte isn''t start of preamble!', '!'); jumpout end; p := Dget1byte; if (p <> 2) then writeln(logfile,'identification in byte 1 should be ', 2: 1, '!'); numerator := Dsign4byte; denominator := Dsign4byte; if (numerator <= 0) then begin write(' ', 'Bad DVI file: ', 'numerator is ', numerator: 1, '!'); writeln(logfile, 'Bad DVI file: ', 'numerator is ', numerator: 1, '!'); jumpout end; if (denominator <= 0) then begin write(' ', 'Bad DVI file: ', 'denominator is ', denominator: 1, '!'); writeln(logfile, 'Bad DVI file: ', 'denominator is ', denominator: 1, '!'); jumpout end; conv := numerator / 254000.0 * (resolution / denominator); mag := Dsign4byte; if (mag <= 0) then begin write(' ', 'Bad DVI file: ', 'magnification is ', mag: 1, '!'); writeln(logfile, 'Bad DVI file: ', 'magnification is ', mag: 1, '!'); jumpout end; magfactor := mag / 1000.0; trueconv := conv; conv := trueconv * magfactor; p := Dget1byte; (* the 'k' of the preamble *) while p > 0 do begin p := p - 1; waste := Dget1byte; end; skippages; if not inpostamble then begin while (maxpages > 0) do begin (* while *) maxpages := maxpages - 1; if (not dopage) then begin write(' ', 'Bad DVI file: ', 'page ended unexpectedly', '!'); writeln(logfile, 'Bad DVI file: ', 'page ended unexpectedly', '!'); jumpout end; (* now we are at an EOP ---end of page *) (* flushout GDVIbuffer, and reset counters *) { writeln('EOP: bytes used= ',GDVIBuf.TotByteLen:0); } WriteDVIBuf; ClearDVIBuf; multifigure := 0; pgfigurenum := 0; FTBDs := 0; didnewfonts := false; repeat k := Dget1byte; if (k >= 243) and (k < 247) then begin (* fontdefs *) p := firstpar(k); definefont(p); k := 138 end; until (k <> 138); (* nop *) if (k = 248) then begin inpostamble := true; ourq := DVIMark + TotBytesWritten - 1; goto 30 end; if (k = 139) then (* BOP *) begin newbackptr := DVIMark + TotBytesWritten - 1; currpagenum := Dsign4byte; (* Count[0] *) for k := 1 to 9 do waste := Dsign4byte; (* WAS count[k] := *) waste := Dsign4byte; (* backpointer *) BackupInBuf (4); cmdSigned (oldbackptr, 4); oldbackptr := newbackptr; write(' ['); write(logfile,' ['); end else begin (* NOT bop?? *) writeln('We did not find BOP when expected'); writeln(logfile,'We did not find BOP when expected'); jumpout; end; end; (* while *) 30: end; (* if not inpostamble *) if (not inpostamble) then skippages; waste := Dsign4byte; (* ptr to the last bop in file *) BackupInBuf (4); cmdSigned (oldbackptr, 4); readpostamble; WriteDVIBuf; while ((TotBytesWritten mod 4) <> 0) do OutputByte(223); (* final signatures *) writeln; writeln(logfile); write ('Output written on '); writestrng(outname, false); write(' (',currpagenum:0,' page'); if (currpagenum > 1) then write('s'); writeln(', ',TotBytesWritten:0,' bytes).'); write (logfile,'Output written on '); writestrng(outname, true); write(logfile,' (',currpagenum:0,' page'); if (currpagenum > 1) then write(logfile,'s'); writeln(logfile,', ',TotBytesWritten:0,' bytes).'); write ('Log written on '); writestrng(logfilnam, false); writeln; write (logfile,'Log written on '); writestrng(logfilnam, true); writeln (logfile); writeln; writeln(logfile); 666: if (ErrorOccurred) then begin writeln; writeln('Some error(s) occurred. Please check Logfile for details'); writeln('Assume that the outputfile is incorrect'); end; end.