// PLMaker.bcpl

// edited by Ramshaw  December 23, 1980  1:57 PM remove f-kerning
//   for italic fonts, since italic correction takes care of it
// edited by Ramshaw  December 14, 1980  5:04 PM new PL and TFM format,
//    more data about fonts.  Added PLMakerData module
// edited by Ramshaw  July 11, 1980  11:58 AM ignore chars above #177, 
//     plus new families
// edited by Guibas  October 18, 1979  8:54 AM new OS plus more families
// edited by Wyatt  September 4, 1979  1:59 PM (NEW PL FORMAT)
// edited by Wyatt  May 3, 1979  3:02 PM (changed SPACE computation)
// edited by Wyatt  April 29, 1979  5:43 PM (added TIMESROMANSC,HELVETICASC)
// edited by Wyatt  February 19, 1979  3:18 PM
// edited by Guibas  February 18, 1979  1:13 PM to add trident code
// modified 2/12/79 to create .PL files for an entire character dictionary


// load with: Bldr PLMaker PLMaker1 PLMakerData gp tfs* loadram triconmc
// (tfs* from <alto>tfs.dm)

// read a prepress character (.ac) file, and produce a property list (.PL)
// file suitable for consumption by a sail program which produces
// "TFP" files for TEX

get "altodefs.d"; // from [maxc]<alto>
get "streams.d"; // from [maxc]<alto>
get "ix.dfs"; // from [ivy]<tex>
get "plmaker.d"; // from [ivy]<tex>

manifest
[
cr=$*n
quadchar=#17 // em space in newer PARC fonts
]

external
[
// from GP
SetupReadParam; ReadParam;

// from OS
GetFixed; FixedLeft;
InitializeZone; Allocate; Free;
OpenFile; ReadBlock; WriteBlock;
Gets; Puts; Endofs; Resets; Closes;
Ws; Wo; Wns; Wss;
SetFilePos; FilePos;
DoubleAdd; MoveBlock; SetBlock; Usc; Min; Max;
fpComCm; dsp; SetEndCode;
lvUserFinishProc; lvSwatContextProc;

// Trident disk stuff
LoadRam; // from LoadRam
DiskRamImage; // from TriConMc
TFSSwatContextProc; TFSClose; TFSInit; TFSSilentBoot; // from TFS*
TFSzone; TFSdisk;

// from PLMaker1
Str; Chr; Cr; Dec; UDec; Oct; DNum; ONum; XNum; Char; RNumOver10; Begin; End;
SetPos; GetPos; IncPos; DoubleSub; MulDiv;
WordsForString; CopyString; StringMatch; AppendChar; AppendNum; AppendStr;
DefaultExtension; StripExtension;

//from PLMakerData
InitTables

// outgoing statics
outstream; lev; z; flags; tflags; names; tnames; nt; cwvec;

// outgoing proc (to PlMakerData)
MakeStringCopy
];

static
[
z // free storage zone
logstream // stream for display and log file
infilename
outfilename
instream1=0 // (word) stream on the input file
instream2=0 // another (word) stream on the input file
outstream=0 // (byte) stream on the output file
bc; ec; // beginning and ending chars
nc; // number of characters
fam; face; siz; rot; // family code, face code, size in micas, rotation
sl; wt; ex; // slope, weight, expansion (e.g., $I, $M, $R)
resx; resy; // resolutions (10*number of bits per inch)
cwvec // pointer to CharWidth array from input file
dirvec // pointer to directory array from input file
cwLen // length of cwvec
dirLen // length of dirvec
dirfp // file position of directory
lev=0 // indentation level
fixedPitch // true if font has fixed pitch
fLigs // true if font has "f" ligatures
dLigs // true if font has en-dash and em-dash
mQuad // true if font has em-quad
s40  // true if #40 is a word space
CScode // codingscheme code number
pts  // size of font in PARC points from the dictionary file
texStyle=true // true if PL file is being produced for TEX.
names // pointer to array of names from dictionary
flags // pointer to array of flags associated with names
tnames // pointer to array of family names to be considered
tflags // pointer to array of flags associated with tnames
nt // number of entries in tnames
savedUFP; savedSCP;
TFSzone; TFSdisk = 0 // for the Trident
];

structure S: // BCPL string
[
length byte
body^0,255 byte
];

let main() be
[
OpenLog("PLMaker.log");

Log("PLMaker of December 18, 1980:*n");

InitStorage();

ReadComCm();

Log("Reading file: "); Log(infilename); Log(".*n*n");

OpenInputFile();

InitTables();

ScanDictionary();

CloseFiles();
];

and
InitStorage() be
[
let res = LoadRam(DiskRamImage,true);
let AltoVersion=(table [ #61014; #1401 ] )()
let eng=AltoVersion<<VERS.eng
if (res ls 0) & (eng ls 4) then [ Ws("Cannot load the RAM."); finish ];
//don't worry if the RAM won't load on a Dolphin or Dorado
savedUFP=@lvUserFinishProc;
@lvUserFinishProc=MyFinish;
savedSCP=@lvSwatContextProc;
@lvSwatContextProc=TFSSwatContextProc;
// make a storage zone
manifest maxzlength=77777b; // max length for a zone
let zlength=FixedLeft()-2500; // maximum available space
if Usc(zlength, maxzlength) gr 0 do zlength=maxzlength;
z=InitializeZone(GetFixed(zlength), zlength);
TFSdisk=TFSInit(z, true, (eng eq 5?1,0)); //drive number is 1 on Dorado
];

and
OpenLog(logname) be
[
logstream=OpenFile(logname, ksTypeWriteOnly, charItem);
if logstream eq 0 do [ Ws("Can't open log file"); abort ];
];

and
Log(s) be [ Ws(s); Wss(logstream,s) ];
// writes string s on both display and log file

and
ReadComCm() be
[
let sv=vec 50; // space for file names
let swv=vec 50; // space for switches
// prepare to read Com.Cm
SetupReadParam(sv, swv);

// interpret global switches
for i=1 to swv!0 do switchon swv!i into
	[
	case $T: case $t: texStyle=true; endcase;
	];

// get input file name from command line
ReadParam($P, "Dictionary file: ");
infilename=MakeStringCopy(sv);
];

and
MyFinish() be
 [ if TFSdisk ne 0 then TFSClose(TFSdisk)
   @lvUserFinishProc=savedUFP
   @lvSwatContextProc=savedSCP
   TFSSilentBoot()
   finish
 ]

and
OpenInputFile() be
[
if TFSdisk then
 [ instream1=OpenFile(infilename,ksTypeReadOnly,wordItem,0,0,0,z,0,TFSdisk)
   instream2=OpenFile(infilename,ksTypeReadOnly,wordItem,0,0,0,z,0,TFSdisk)
   // SetEndCode(TFSInit);
 ]
//now, try to find it on 31
if instream1 eq 0 then
	[
	instream1=OpenFile(infilename, ksTypeReadOnly, wordItem);
	instream2=OpenFile(infilename, ksTypeReadOnly, wordItem);
	]
if instream1 eq 0 do Punt("Can't open input file");
];

and
CloseFiles() be
[
Closes(logstream);
unless instream1 eq 0 do Closes(instream1);
unless instream2 eq 0 do Closes(instream2);
unless outstream eq 0 do Closes(outstream);
];

and
ScanDictionary() be
[
// scan through the dictionary index
	[
	let ix=vec IXLMax; // space for index entry
	ix!0=Gets(instream1); // first word of ix contains type and length
	if ix>>IX.Type eq IXTypeEnd break; // end of index
	ReadBlock(instream1, ix+1, ix>>IX.Length-1); // read rest of index entry
	switchon ix>>IX.Type into
		[
		case IXTypeName:
			EnterName(lv ix>>IXN.Name, ix>>IXN.Code);
			endcase;
		case IXTypeChars:
		case IXTypeOrbitChars:
		case IXTypeMultiChars:
			ProcessChars(ix);
		default: endcase; // just ignore it
		];
	] repeat
];

and
EnterName(name, code) be
[
names!code=MakeStringCopy(name);
// look up the name in tnames
for i=0 to nt-1 do
	[
	if StringMatch(name,tnames!i) do
		[
		flags!code=tflags!i;
		(flags!code)<<incl=1;
		return;
		];
	];
// name not found in tnames
(flags!code)<<incl=0;
];

and
ProcessChars(ix) be
[
// construct font name
let psa=nil; // POINTER TO segment starting address
switchon ix>>IX.Type into
	[
	case IXTypeChars:
	case IXTypeOrbitChars:
		fam=ix>>IX.fam;
		face=ix>>IX.face;
		siz=ix>>IX.siz;
		bc=ix>>IX.bc; ec=ix>>IX.ec;
		rot=ix>>IX.rotation;
		resx=ix>>IX.resolutionx; resy=ix>>IX.resolutiony;
		psa=lv ix>>IX.sa;
		endcase;
	case IXTypeMultiChars:
		fam=ix>>IXM.fam;
		face=ix>>IXM.face;
		siz=ix>>IXM.siz;
		bc=ix>>IXM.bc; ec=ix>>IXM.ec;
		rot=ix>>IXM.rotation;
		resx=ix>>IXM.resolutionx; resy=ix>>IXM.resolutiony;
		psa=lv ix>>IXM.segs^1.sa; // most recent widths are in 1st seg
		endcase;
	default: Log("[??? IX.Type not chars]*n"); return;
	];
pts=MulDiv(siz,72,2540); // point size
if PARCface(face) then DecodeFace(face, lv wt, lv sl, lv ex);
let name=vec 30; // space for the name
CopyString(name, names!fam); // first, the family name
if (flags!fam)<<ptsize eq 0 then AppendNum(name, pts); // font doesn't
		//scale, so point size should be in file name
//now, put the face into the file name:
test PARCface(face)
 ifso	[
	if wt ne $M do AppendChar(name, wt); // now the face
	if sl ne $R do AppendChar(name, sl);
	if ex ne $R do AppendChar(name, ex);
	]
 ifnot	[
	AppendNum(name,(254-face)/2); //design size in points
	if (face&1) ne 0 then AppendChar(name, $H); // and a half 
	]

Log(name);
if (flags!fam)<<ptsize ne 0 then 
	[
	let s=vec 20
	CopyString(s, " at ")
	AppendNum(s, pts)
	AppendStr(s, "pts")
	Log(s)
	]
if rot ne 0 do
	[
	let s=vec 20;
	CopyString(s, " [rotation ");
	AppendNum(s, (rot+30)/60); // rotation in degrees
	AppendStr(s, "]");
	Log(s);
	];
let f=flags!fam;
if (f<<incl eq 0) % (rot ne 0) % ((f<<ptsize ne 0)&(f<<ptsize ne pts)) do
	[ Log(" ...skipped*n"); return ];
if not PARCface(face) then 
	[ Log("[??? Can't handle non-PARC style fonts!]*n"); return ]
fixedPitch=f<<fixed ne 0;
fLigs=f<<fligs ne 0;
dLigs=f<<dligs ne 0;
mQuad=f<<mquad ne 0;
s40=f<<s40 ne 0;
CScode=f<<CS;

AppendStr(name, ".PL"); // now name is full filename
outfilename=name;
outstream=OpenFile(outfilename, ksTypeWriteOnly, charItem);
if outstream eq 0 do [ Log("[??? Can't open output file]*n"); return ];

SetPos(instream2, psa); // position stream to beginning of segment

// read charwidth array
let nc=ec-bc+1; // number of chars
cwLen=nc*CharWidthsize;
ReadBlock(instream2, cwvec, cwLen);

Log(" ...");

MakePLfile();

Closes(outstream); outstream=0;
Log("OK*n");
];

and
MakePLfile() be
[
// the routine that does the real work
let reso=resx; // TENTHS of pixels per inch

Begin(); Str("FAMILY "); Str(names!fam); End();
Begin(); Str("FACE F "); Chr(wt); Chr(sl); Chr(ex); End();
Begin(); Str("DESIGNSIZE"); DNum(pts); End();
Begin(); Str("CHECKSUM"); DNum(0); End();
Begin(); Str("CODINGSCHEME "); Str(CodeToString(CScode)); End();
Begin(); Str("SEVENBITSAFEFLAG "); Str("TRUE"); End();
Begin(); Str("RESOLUTION"); RNumOver10(reso); End();
Begin(); Str("MICASIZE"); DNum(siz); End();
Begin(); Str("UNITS "); Str("PIXELS"); End();

Begin(); Str("TEXINFO"); Cr();
let italic=sl eq $I;
// for italic fonts, make slant 16%
Begin();
Str("SLANT R "); Str(italic?"0.160","0.000"); // pardon my kludge
End();
let xtrspace=vec 1
if s40 do
	[
	let space,str,shr=vec 1,vec 1,vec 1;
	let cw=Cwp(#40);
	let wx=lv cw>>CharWidth.WX;
	let zero=vec 1;
	zero!0,zero!1=0,0;
	test fixedPitch
	ifnot
		[
		let half=vec 1; // half _ 1/2 wx
		half!1=(wx!1)rshift 1 + (wx!0)lshift 15;
		half!0=(wx!0)rshift 1;
		space!0,space!1=wx!0,wx!1; // space _ wx
		DoubleAdd(space, half); // space _ space + 1/2 wx  (space = 3/2 wx)
		str!0,str!1=wx!0,wx!1; // str _ wx
		shr!0,shr!1=half!0,half!1; // shr _ 1/2 wx
		xtrspace!0,xtrspace!1=half!0,half!1; // xtrspace _ 1/2 wx
		]
	ifso
		[
		space!0,space!1=wx!0,wx!1; // space _ wx
		xtrspace!0,xtrspace!1=wx!0,wx!1; // xtrspace _ wx
		str!0,str!1=0,0; // str _ 0
		shr!0,shr!1=0,0; // shr _ 0
		];
	Begin(); Str("SPACE"); XNum(space); End();
	Begin(); Str("STRETCH"); XNum(str); End();
	Begin(); Str("SHRINK"); XNum(shr); End();
	]
if InFont($x) do
	[
	let cw=Cwp($x);
	let xh=cw>>CharWidth.H+cw>>CharWidth.YB;
	Begin(); Str("XHEIGHT"); DNum(xh); End();
	]
Begin(); Str("QUAD");
test mQuad
	ifso XNum(lv Cwp(quadchar)>>CharWidth.WX)
	ifnot RNumOver10(MulDiv(reso,siz,2540)); //remember reso=10*resolution
End();
if s40 do [ Begin(); Str("EXTRASPACE"); XNum(xtrspace); End() ];
End(); // of TEXINFO

if fLigs % dLigs do MakeLigtable();

for c=bc to ec do if InFont(c) do
	[
	Begin();
	Str("CHARACTER"); Char(c); Cr();
	OutCharInfo(c);
	End();
	];

]

and
Label(c) be
[
Begin(); Str("LABEL"); Char(c); End();
]

and
Lig(c1,c2) be
[
Begin(); Str("LIG"); Char(c1); Char(c2); End();
]

and
Kern(c,d) be
[
Begin(); Str("KRN"); Char(c); DNum(d); End();
]

and
Stop() be
[
Begin(); Str("STOP"); End();
]

and
MakeLigtable() be
[
Begin(); Str("LIGTABLE"); Cr();
if fLigs do
	[
	Label($f);
	let cw=Cwp($f)
	let wx=lv cw>>CharWidth.WX
	let wid=wx!0;
	let corr=cw>>CharWidth.W+cw>>CharWidth.XL-wid
	if (corr gr 0)&(sl eq $R) then 
		[
		if InFont($') then Kern($',corr)
		if InFont($)) then Kern($),corr)
		if InFont($]) then Kern($],corr)
		if InFont($!) then Kern($!,corr)
		if InFont($?) then Kern($?,corr)
		]
	Lig($f,#6); Lig($i,#24); Lig($l,#25); Stop(); // ff, fi, fl
	Label(#6);
	cw=Cwp(#6)
	wx=lv cw>>CharWidth.WX
	wid=wx!0;
	corr=cw>>CharWidth.W+cw>>CharWidth.XL-wid
	if (corr gr 0)&(sl eq $R) then 
		[
		if InFont($') then Kern($',corr)
		if InFont($)) then Kern($),corr)
		if InFont($]) then Kern($],corr)
		if InFont($!) then Kern($!,corr)
		if InFont($?) then Kern($?,corr)
		]
	Lig($i,#21); Lig($l,#22); Stop(); // ffi, ffl
	]
if dLigs do
	[
	Label($-);
	Lig($-,#26); Stop(); // -- = <en dash>
	Label(#26);
	Lig($-,#23); Stop(); // <en dash>- = <em dash>
	]
End(); // of LIGTABLE
]

and
Cwp(c)=cwvec+(c-bc)*CharWidthsize; // pointer to CharWidth structure for c

and
InFont(c) = bc le c & c le ec & Cwp(c)>>CharWidth.H ne HNonExCode;

and
OutCharInfo(c) be
[
let cw=Cwp(c);
let wx=lv cw>>CharWidth.WX;
Begin(); Str("CHARWD"); XNum(wx); End();
let ht=cw>>CharWidth.H+cw>>CharWidth.YB;
Begin(); Str("CHARHT"); DNum(Max(ht,0)); End();
let dp=-cw>>CharWidth.YB;
Begin(); Str("CHARDP"); DNum(Max(dp,0)); End();
let wid=wx!0; // truncate, to round italic correction up
let corr=cw>>CharWidth.W+cw>>CharWidth.XL-wid;
if corr gr 0 do [ Begin(); Str("CHARIC"); DNum(corr); End() ];
];

// from fontwidths.bcpl
and
DecodeFace(face,w,s,e) be [
	@s=(table [ $R; $I ])!(face&1)
	face=face rshift 1
	@w=(table [ $M; $B; $L ])!(face rem 3)
	face=face/3
	@e=(table [ $R; $C; $E ])!(face rem 3)
]

and
PARCface(face) = valof
[
if face ls 0 then resultis false
if face ge 18 then resultis false
resultis true
]

and
CodeToString(code) =valof
[
switchon code into
	[
	  case CSxeroxtext: resultis "XEROX TEXT"
	  case CSalphabetic: resultis "ALPHABETIC"
	  case CSpi: resultis "PI"
	  case CSgraphic: resultis "GRAPHIC"
	  case CSxeroxgreek: resultis "XEROX GREEK"
	  case CSxeroxcyrillic: resultis "XEROX CYRILLIC"
	  case CSsail: resultis "SUAI"
	  case CSsanitizedsail: resultis "SANITIZED SUAI"
	]
]

and
// allocate space for a new string and copy s into it
MakeStringCopy(s) = valof
[
let nw=WordsForString(s); // number of words required
let ss=Allocate(z, nw);
MoveBlock(ss, s, nw);
resultis ss;
];

and
Punt(string) be
[
Log("*nPunt: "); Log(string); Log("*n");
CloseFiles();
abort;
];