// acmerge.bcpl
// April 29, 1979  4:53 PM

// modified by D. Wyatt  April 29, 1979  3:49 PM
//  to merge orbit format characters

// load with: Bldr acmerge gp

// merge characters from several prepress character (.AC) files
// this program reads an input file of the following form:
//
// 1: timesroman10.ac;
// 2: timesroman10i.ac;
// 3: hippo10.ac;
// 4: symbol10.ac;
// 0: techroman10.ac; -- the output file; must be last
//
// [0:9] _ 1[0:9]; -- numerals from regular times roman
// [A:Z] _ 3[a:z]; -- A to Z are lower case greek alphabet
// [a:z] _ 2[a:z]; -- lower case alphabet is italic times roman
// [+] _ 4[+];  [-] _ 4[-]; -- plus and minus from symbol font
// [!]_4[56]; [165]_1[@]; [136]_4[136];

get "streams.d";
get "ix.dfs";

manifest
[
maxf=9; // greatest permissible file number
sep=$:  // character range separator
syntaxErr=1;
fileErr=2;
maxchars=200b; // greatest possible number of characters
];

static
[
z // free storage zone
instream // stream on the input text file
p // pointer into pstack
pstack // stack of put back characters
eof // true if end of input file reached
c // char fetched from input text
files // pointer to vector of file stream handles
firstf // number of lowest-numbered input file
charvec // vector of C structures
bc; ec; // beginning and ending chars of output font
nc;
ocwlength
odirlength
ixtype=0 // character IX type (IXTypeChars or IXTypeOrbitChars)
];

external // from OS
[
// from GP
SetupReadParam; ReadParam;

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

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

// information for an input font file
structure F:
[
stream word // a stream on the file
ixn word // pointer to name index entry
ix word // pointer to character index entry
cw word // pointer to charwidth array
dir word // pointer to directory array
dirfp word 2 // file pointer to directory
name word // pointer to a string containing the file name
];
manifest Fsize=size F/16;

// describes source for an output file character
structure C:
[
file byte; // which input file
char byte; // which character
];

let main() be
[
Ws("AcMerge of April 29, 1979*n");

Init()

GetFiles();

GetCommands();

InitOutputFile();

for i=bc to ec do
	[
	let ch=charvec!i;
	unless ch eq -1 do CopyChar(i, ch<<C.char, ch<<C.file);
	];

FinishOutputFile();

CloseFiles();
];

and
Init() be
[
// make a storage zone
manifest maxzlength=77777b; // max length for a zone
let zlength=FixedLeft()-200; // maximum available space
if Usc(zlength, maxzlength) gr 0 do zlength=maxzlength;
z=InitializeZone(GetFixed(zlength), zlength);

// get input text file name from Com.Cm
let comcm=OpenFile("Com.Cm", ksTypeReadOnly, charItem, 0,
	fpComCm);
let inFilename=vec 30; // space for string
SetupReadParam(0,0,comcm);
instream=ReadParam($I, "Input file: ", inFilename);
Closes(comcm);

pstack=Allocate(z, 10);
p=0;
eof=false;

files=Allocate(z, maxf+1);
SetBlock(files, 0, maxf+1);
firstf=maxf+1;

charvec=Allocate(z, maxchars);
SetBlock(charvec, -1, maxchars);
];

and
GetFiles() be
[
// get file names and open files
// file 0 is output file
let filename=vec 30;
let pf=nil;
	[
	let f=InFile();
	Eat($:);
	InString(filename);
	Eat($;);
	unless files!f eq 0 do
		Punt("duplicate file number");
	pf=Allocate(z, Fsize);
	files!f=pf;
	let nl=(filename>>S.length+2) rshift 1; // name length in words
	pf>>F.name=Allocate(z, nl);
	MoveBlock(pf>>F.name, filename, nl); // copy filename
	pf>>F.ixn=Allocate(z, IXLName);
	pf>>F.ix=Allocate(z, IXLChars);
	let stream=OpenFile(filename, f eq 0?ksTypeWriteOnly,ksTypeReadOnly,
		0,0,0,0,z); // use our own zone so we can open lots of files
	pf>>F.stream=stream;
	if stream eq 0 do Punt(fileErr, filename);
	if f eq 0 break
	ReadIndex(f);
	Ws("*nInput file "); Puts(dsp, f+$0);
	Ws(": "); Ws(filename);
	if f ls firstf do firstf=f;
	] repeat
Ws("*nOutput file: "); Ws(filename);
];

and
ReadIndex(f) be
[
let pf=files!f;
let s=pf>>F.stream;

// read name index entry
ReadBlock(s, pf>>F.ixn, IXLName);
unless pf>>F.ixn>>IXN.Type eq IXTypeName do
	Punt("bad IXN");

// read character index entry
let ix=pf>>F.ix;
ReadBlock(s, ix, IXLChars);
let t=ix>>IX.Type;
test ixtype eq 0
ifso
	[
	unless t eq IXTypeChars % t eq IXTypeOrbitChars do
		Punt("IX type not chars");
	ixtype=t;
	]
ifnot unless t eq ixtype do Punt("IX type mismatch");

// index should end here
let ixe=vec IXLEnd;
ReadBlock(s, ixe, IXLEnd);
unless ixe>>IXH.Type eq IXTypeEnd do
	Punt("expected end of index");

SetPos(s, lv ix>>IX.sa); // position stream to beginning of segment

// read charwidth array
let nc=ix>>IX.ec-ix>>IX.bc+1; // number of chars
let cwlength=nc*CharWidthsize;
pf>>F.cw=Allocate(z, cwlength);
ReadBlock(s, pf>>F.cw, cwlength);

// read directory array
GetPos(s, lv pf>>F.dirfp); // remember fp of directory
let dirlength=nc*2;
pf>>F.dir=Allocate(z, dirlength);
ReadBlock(s, pf>>F.dir, dirlength);
];

and
GetCommands() be
[
let ofc, olc, ifc, ilc = nil,nil,nil,nil;
let range=nil; // true if range of characters specified
let f=nil; // input file number
[
range=false;
let t=InChar(); if eof break; PutBack(t);
Eat($[);
ofc=InCode();
let t=InChar();
test t eq sep
	ifso [ olc=InCode(); range=true ]
	ifnot PutBack(t);
Eat($]); Eat($_);
f=InFile();
Eat($[);
ifc=InCode();
if range do [ Eat(sep); ilc=InCode() ];
Eat($]); Eat($;);
if range do unless olc-ofc eq ilc-ifc do
	Punt("range mismatch");
let n=range?olc-ofc,0;
for i=0 to n do RecordChar(ofc+i, ifc+i, f);
] repeat
Closes(instream);
instream=0;
];

and
RecordChar(oc, ic, f) be
[
if files!f eq 0 do Punt("undefined input file");
unless charvec!oc eq -1 do
	Warn("output char multiply defined");
let ch=nil;
ch<<C.file=f;
ch<<C.char=ic;
charvec!oc=ch;
];

and
InitOutputFile() be
[
let pf=files!0;
let s=pf>>F.stream;

// copy char index from first input file
MoveBlock(pf>>F.ix, (files!firstf)>>F.ix, IXLChars);

bc=0;
while charvec!bc eq -1 do
	[ bc=bc+1; if bc ge maxchars do Punt("no output chars"); ];
ec=maxchars-1;
while charvec!ec eq -1 do ec=ec-1;
nc=ec-bc+1; // number of chars in output font

ocwlength=nc*CharWidthsize;
odirlength=nc*2;
pf>>F.cw=Allocate(z, ocwlength);
pf>>F.dir=Allocate(z, odirlength);
SetBlock(pf>>F.cw, -1, ocwlength);
SetBlock(pf>>F.dir, -1, odirlength);

// compute size of index part of output file
let ixwords=IXLName+IXLChars+IXLEnd;
// set output file position to start of segment
Resets(s);
IncPos(s, ixwords);
GetPos(s, lv pf>>F.ix>>IX.sa); // fp of start of segment
IncPos(s, ocwlength);
GetPos(s, lv pf>>F.dirfp); // fp of start of directory
IncPos(s, odirlength);
// now stream points to position for first raster
];

and
CopyChar(outchar, inchar, infile) be
[
let pf=files!infile;

Ws("*nCharacter "); Wchar(outchar); Ws(" from ");
Ws(pf>>F.name); Ws(" character "); Wchar(inchar);

let s=pf>>F.stream;
let ix=pf>>F.ix;
let ibc=ix>>IX.bc;
let iec=ix>>IX.ec;
let delc=inchar-ibc;
let cwp=pf>>F.cw+delc*CharWidthsize;
let dirp=pf>>F.dir+delc*2;
if inchar ls ibc % inchar gr iec % cwp>>CharWidth.H eq -1 do
	[ Warn("input char missing"); return ];
let fp=vec 1;
MoveBlock(fp, lv pf>>F.dirfp, 2);
DoubleAdd(fp, dirp); // now fp points to raster for char
SetPos(s, fp);
let nbw=nil; // number of buffer words
switchon ixtype into
[
case IXTypeChars:
	[
	let fhead=Gets(s); // get raster header word
	let nrw=fhead<<FHEAD.hw*fhead<<FHEAD.ns; // number of raster words
	nbw=1+nrw;
	endcase;
	];
case IXTypeOrbitChars:
	[
	let w1=Gets(s);
	let w2=Gets(s);
	let h=-w1; // w1 is -height
	let w=w2+1; // w2 is width-1
	let nrw=(h*w+15)/16; // number of raster words
	nbw=2+nrw;
	if (nbw&1)ne 0 do nbw=nbw+1; // round up to an even number
	endcase;
	];
default: Punt("bad ixtype");
];
let buffer=Allocate(z, nbw);
SetPos(s, fp);
ReadBlock(s, buffer, nbw);

let opf=files!0;
let outs=opf>>F.stream;
let odelc=outchar-bc;
let ocwp=opf>>F.cw+odelc*CharWidthsize;
MoveBlock(ocwp, cwp, CharWidthsize);
let odirp=opf>>F.dir+odelc*2;
GetPos(outs, odirp); // get ouput file position
DoubleSub(odirp, lv opf>>F.dirfp);
WriteBlock(outs, buffer, nbw);
Free(z, buffer);
];

and
FinishOutputFile() be
[
let pf=files!0;
let ixn=pf>>F.ixn;
let ix=pf>>F.ix;
let s=pf>>F.stream;

SetBlock(ixn, 0, IXLName);
ixn>>IXN.Type=IXTypeName;
ixn>>IXN.Length=IXLName;
ixn>>IXN.Code=0;
ixn>>IXN.Name=0; // null string

ix>>IX.fam=0;
ix>>IX.bc=bc;
ix>>IX.ec=ec;
// compute segment length
GetPos(s, lv ix>>IX.len);
DoubleSub(lv ix>>IX.len, lv ix>>IX.sa);

let ixe=vec IXLEnd;
ixe>>IXH.Type=IXTypeEnd;
ixe>>IXH.Length=IXLEnd;

// write index
Resets(s);
WriteBlock(s, ixn, IXLName);
WriteBlock(s, ix, IXLChars);
WriteBlock(s, ixe, IXLEnd);

// write fixed-length part of segment
SetPos(s, lv ix>>IX.sa); // this shouldn't really be necessary
WriteBlock(s, pf>>F.cw, ocwlength);
WriteBlock(s, pf>>F.dir, odirlength);

Resets(s); // so it doesn't get truncated!
];

and
CloseFiles() be
[
unless instream eq 0 do Closes(instream);
for f=0 to maxf do
	[
	let pf=files!f;
	unless pf eq 0 do
		[
		let s=pf>>F.stream;
		unless s eq 0 do Closes(s);
		];
	];
];


// routines for scanning input text file

// get next input character
and
InCh() = valof
[
test Endofs(instream) ifso [ eof=true; c=-1 ]
ifnot test p gr 0
	ifnot c=Gets(instream)
	ifso [ p=p-1; c=pstack!p ];
resultis c;
];

and
InNB() be
[
InCh() repeatwhile c eq $*s % c eq $*n;
]

// get next nonblank character
and
InChar() = valof
[
InNB();
let t=c;
if t eq $- do
	[
	InCh();
	test c eq $-
		ifso [ InCh() repeatuntil c eq $*n; InNB() ]
		ifnot [ PutBack(c); c=t ];
	];
resultis c;
];

and
Eat(char) be
[ unless InChar() eq char do Punt(syntaxErr); ];

// put back the last char so that next InCh will fetch it
and
PutBack(c) be
[
pstack!p=c;
p=p+1;
];

// returns true if character c is a digit
and
Digit(c) = c ge $0 & c le $9;

// get file number (should be a digit from 0 to 9)
and
InFile() = valof
[
InChar();
test Digit(c)
ifso resultis c-$0;
ifnot Punt(syntaxErr, "bad file number");
];

and IdChar(c) =
c ge $A & c le $Z
% c ge $a & c le $z
% Digit(c)
% c eq $.
% c eq $-;

and
InString(s) be
[
let i=0;
PutBack(InChar()); // move up to first nonblank
[
InChar(); unless IdChar(c) do [ PutBack(c); break ];
s>>S.body^i=c;
i=i+1;
] repeat
s>>S.length=i;
];

// get character code (either character itself or octal code)
and
InCode() = valof
[
let n=0; // character code, if given as an octal number
let nd=0; // number of digits scanned
PutBack(InChar());  // move to next nonblank character
	[
	InCh();
	unless Digit(c) break;
	n=8*n+(c-$0);
	nd=nd+1;
	] repeat
if nd eq 0 resultis c; // first char was non-digit
PutBack(c); // put back last char
resultis nd gr 1?n,n+$0;
];


// routines for dealing with file positions in words

and
SetPos(stream, fp) be
[
let fph, fpl=fp!0, fp!1; // don't disturb given fp
fph=(fph lshift 1)+(fpl ls 0?1,0)
fpl=fpl lshift 1
SetFilePos(stream, fph, fpl)
]

and
GetPos(stream, fp) be
[
FilePos(stream, fp)
fp!1=(fp!1 rshift 1)+((fp!0 & 1) eq 1?#100000,0);
fp!0=fp!0 rshift 1
]

and
IncPos(stream, nwords) be // increment file position by nwords
[
let fp=vec 1;
GetPos(stream, fp);
let t=vec 1; t!0,t!1=0,nwords;
DoubleAdd(fp, t);
SetPos(stream, fp);
]

and
DoubleSub(a, b) be
[
// does a _ a - b
let minusb=vec 1;
minusb!0, minusb!1 = not b!0, not b!1;
DoubleAdd(minusb, table [ 0; 1 ]);
DoubleAdd(a, minusb);
];

and
Punt(err, string; numargs na) be
[
Ws("*nPunt! ");
switchon err into
[
case syntaxErr: Ws("Syntax error"); endcase;
case fileErr: Ws("File error"); endcase;
default: Ws(err);
];
if na gr 1 do [ Ws(": "); Ws(string) ];
CloseFiles();
abort;
];

and
Warn(string) be
[
Ws("*nWarning: "); Ws(string);
];

and
Wchar(c) be Wns(dsp, c, 3, 8);