(*$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.