// Merge code for Pressedit
// bcpl/f presseditmerge.bcpl

// Copyright Xerox Corporation 1979, 1980, 1981, 1982

// Last edited by 
// Bob Sproull Oct 9, 1982. Fixed bug in MergePressPages causing
//  infinite loop if missing file or arrow; added check for exceeding
//  maximum number of illustrations
// Lyle Ramshaw May 29, 1982  2:44 PM  Added the /A switch as an
//  alternative to the /M, in which all illustrations are merged into
//  all pages without any checking for arrows on either side, and
//  without any shifting in position.
// Lyle Ramshaw January 14, 1982  3:18 PM allow for high order
//		word of data list dyte start to be non-zero
//	Also fix up SetupEntities to allow for large file addresses
// Lyle Ramshaw January 14, 1981  11:19 AM fix bounds check on EntVec
// RML August 13, 1980  6:22 PM add external files
// RML July 25, 1980  3:13 PM check bounds on EntVec
// William Newman February 8, 1978  10:51 PM fixed draw files bug

get "presseditdefs.bcpl"
get "streams.d"

// outgoing procedures

external [
//	EarsArrowCheck
	MergeIllusFiles
	PressMergeScan
	PressScan
	]

// outgoing statics

// incoming procedures

external [
			// in presseditfns
	AppendChar
	AppendString
	EqStr
	Error
	nth
	pnth
	min
			// in presseditpage
	CopyPressPage
	FixPartDir
	WritePartDir
	WriteDocDir
	CopyPages
	CopyWords
	PGread
	PutPadding
			// in new OS
	Zero
	OpenFile
	Gets
	Puts
	Closes
	DeleteFile
	PositionPage
	PositionPtr
	FilePos
	SetFilePos
	DoubleAdd
	ReadBlock
	WriteBlock
	Ws
	Wl
	Wns
	CallSwat
	]

// incoming statics

external [
	dsp
	FileNames
	NFiles
	Merge
	mergeList
	nIllus
	mergePtr
	docMergePtrs
	illusMergePtrs
	OutPartDir
	OutPartDirPtr
	OutDocDir
	OutputFileName
	EntVec
	InputStream
	InputByteStream
	DocDirList
	]

static
	[
	pressX
	pressY
	xMin
	yMin
	elByte
	elWord
	pressPass
	]

manifest
	[
	chardrop = 100	// allows for drop below char baseline
	maxleft = 85*254
	maxbottom = 11*2540
	markupglitch = 31744		// weird number markup puts in
	]

// checks for one string starting with <==<<
// if so, adds entry to mergelist, increments nIllus
// ignores if name not in FileNames

let MergeFileNo(filename) = valof
	[
	if nth(filename, 0) eq 0 then resultis 0
		// test for ligature
	let tv = vec 30
	tv!0 = 0
	for i = 1 to nth(filename, 0) do
		[
		let c = nth(filename, i)
		test c eq #24		// control-T
		ifso AppendString(tv, "fi")
		ifnot AppendChar(tv, c)
		]
	for i = 0 to NFiles-1 do
		if EqStr(tv, FileNames!i) then resultis i
	resultis -2
	]

and
let MergeIllusFiles(efdlength,fdlength) be
	[
	Wl("*nMerging files:")
	let ddv = vec DDlen - 1
	SetUpMergeDD(ddv, fdlength)
	OutPartDirPtr = OutPartDir	// gradually overwrite part dir
		// note that output file has same number of parts as
		// first input file; therefore OutPartDirPtr addresses
		// both input part and (after fixup) output part
		// after merging, Ptr points to first part of first
		// merge file: font part is written here
	let os = OpenFile("pressedit.scratch", ksTypeWriteOnly)
	InputStream = OpenFile("pressedit.merge", ksTypeReadOnly)

	test Merge eq $A
	  ifso
		[
		for pn=0 to DocDirList>>DD.npages-1 do 
		 MergePressPages(os, OutPartDirPtr, mergeList,
			mergeList+nIllus*MERGElen,pn)
		]
	  ifnot  //so, Merge eq $M
		[
		let pn = 0
		[
		if docMergePtrs!(pn+1) eq -1 then break	// last page done
		test docMergePtrs!pn eq 0
		ifso CopyPressPage(os, OutPartDirPtr, ddv)
		ifnot
			[
			let i = pn + 1
			until docMergePtrs!i ne 0 do i = i + 1
				// gives next non-zero ptr
			MergePressPages(os, OutPartDirPtr, docMergePtrs!pn,
				docMergePtrs!i, pn)
			]
		pn = pn + 1
		] repeat
		]
// fix directories: external file directory first, if present
	unless efdlength eq 0 do [
		PositionPage(InputStream, OutDocDir>>DDV.pdstart - efdlength - fdlength +1)
		ReadBlock(InputStream, EntVec, efdlength lshift 8)
		WriteBlock(os, EntVec, efdlength lshift 8)
		FixPartDir(0, os)	// sets type to 0
		(OutPartDirPtr - PDlen)>>PD.type = 2
		]
//  font directory
	PositionPage(InputStream, OutDocDir>>DDV.pdstart - fdlength +1)
	ReadBlock(InputStream, EntVec, fdlength lshift 8)
	WriteBlock(os, EntVec, fdlength lshift 8)
	FixPartDir(0, os)	// sets type to 0
	(OutPartDirPtr - PDlen)>>PD.type = 1

// part directory
	WritePartDir(os)
// doc directory
	WriteDocDir(os, OutputFileName)
	Closes(os)
	Closes(InputStream)
	DeleteFile("pressedit.merge")
	]

and
let MergePressPages(os, pv, fp, lp, pn) be
	[
	let evec = vec MaxEntities - 1
	let entcount = SetupEntities(pv, evec, os, EntVec)
	Ws("page "); Wns(dsp, pn+1); Puts(dsp, $:)
	let p=fp
	until p eq lp do
		[
		let nextp=p+(Merge eq $A? 2*MERGElen, MERGElen)
		Puts(dsp, $*s)
		if p>>MERGE.file eq 0 then loop
		if p>>MERGE.file eq -2 then
			[
			Ws("missing file ")
			p=nextp
			loop
			]
		Ws(FileNames!(p>>MERGE.file))
		let pp = (Merge eq $A? p+MERGElen, @(illusMergePtrs + p>>MERGE.file))
		if pp eq 0 then
			[
			Ws("(no arrow in figure)")
			p=nextp
			loop
			]
			// illus entry
		let fpv = OutPartDir + (pp>>MERGE.file)*PDlen	// part
		let lastent = evec!0
		let nbytes = vec 1
		nbytes!0=0; nbytes!1=0;
		if lastent ne EntVec then 
		   [ DoubleAdd(nbytes, lv lastent>>EH.dstart1)
		     DoubleAdd(nbytes, lv lastent>>EH.dlength1) ]
		entcount = SetupEntities(fpv, evec, os, lastent + EHlen)
		let negorg = false	// look for -ve xe, ye
		for i = 0 to entcount-1 do
			[
			let ep = evec!i	// ptr to entity
			ep>>EH.xe = ep>>EH.xe + p>>MERGE.x - pp>>MERGE.x
			ep>>EH.ye = ep>>EH.ye + p>>MERGE.y - pp>>MERGE.y
			if ep>>EH.xe ls 0 % ep>>EH.ye ls 0 then negorg = true
			DoubleAdd(lv ep>>EH.dstart1, nbytes)
			]
		if negorg then Ws(" (negative origin)")
		p=nextp
		]
	Puts(os, 0)
	WriteBlock(os, EntVec, evec!0 + EHlen - EntVec)
	let wp = PutPadding(os)
	FixPartDir(wp, os)
	Puts(dsp, $*n)
	]

and
let PressMergeScan(evec, entcount, entptr, pdv) be
	[
	PressScan(evec, entcount, pdv, arrowpass)
	PressScan(evec, entcount, pdv, xypass)
	]

and
let PressScan(evec, entcount, pdv, pass) be
	[
	pressPass = pass		// to avoid reading DL
	let ep = EntVec - EHlen		// -1th entity
	for i = entcount-1 to 0 step -1 do
		[
		elWord = ep + EHlen		// start of next entity code
		elByte = 0
		ep = ep + evec!i		// entity trailer first word
			// check for funny Markup values
		if ep>>EH.xleft gr maxleft then
			ep>>EH.xleft = ep>>EH.xleft - markupglitch
		if ep>>EH.ybottom gr maxbottom then
			ep>>EH.ybottom = ep>>EH.ybottom - markupglitch
		let xright = ep>>EH.xe + ep>>EH.xleft + ep>>EH.width
		let ytop = ep>>EH.ye + ep>>EH.ybottom + ep>>EH.height
			// not used in xy pass
		pressX = ep>>EH.xe		// default value
		pressY = ep>>EH.ye
		xMin = xright	// starting value
		yMin = ytop
			// not used in xy pass
		let str = vec 128
		let dstart = ep>>EH.dstart2
		let objectsfound = false
		let movexy = true		// reset x, y values
		if pass eq xypass & ep>>EH.dstart1 ls 0 then
				// bit set for objects
			[
			ep>>EH.dstart1 = ep>>EH.dstart1 & #77777
			movexy = false
			]
		if pass eq arrowpass then
			[
			PositionPage(InputByteStream,
				pdv>>PD.pstart + 1 + (dstart rshift 9) + 
								(ep>>EH.dstart1 lshift 7))
			PositionPtr(InputByteStream, dstart & #777)
			]
		while elWord ls ep do
			[
			let code = GetELByte()
			let e = code ls #150 ? code & #140,
				code ls #200 ? code & #170,
				code ls #240 ? #200,
				code ls #353 ? Error("entity code"),
				code
			switchon e into
				[
			case #000:	// code+1 chars
				DoShowString(GetDLString(str, code + 1), #40 + code, 1)
				endcase
			case #040:	// skip code+1-#40 chars
				SkipDL(code + 1 - #040)
				endcase
			case #100:	// code+1-#100 chars, skip 1
				DoShowString(GetDLString(str, code + 1 - #100),
					code - #100 + #41, 1)	// note: will fall apart if
					// used for arrows, and string is 33 chars long
				SkipDL(1)
				endcase
			case #140:	// space-x: eskip 1
				GetELByte()
				endcase
			case #150:	// space-y: eskip 1
				GetELByte()
				endcase
			case #160:
			case #170:	// set font
				endcase
			case #200:	// available
				endcase
			case #353:	// n=eread 1, eskip n
				SkipEL(GetELByte())
				endcase
			case #354:	// alt
				SkipEL(10)
				endcase
			case #355:	// copy
				SkipEL(1)
				endcase
			case #356:	// set x
				DoSetX(GetELWord(), ep, movexy)
				endcase
			case #357:	// set y
				DoSetY(GetELWord(), ep, movexy)
				endcase
			case #360:	// show chars
				DoShowString(GetDLString(str, GetELByte()), #361, 2)
				endcase
			case #361:	// skip chars
				SkipDL(GetELByte())
				endcase
			case #362:	// skip control
				SkipDL(GetELWord())
				SkipEL(1)
				endcase
			case #363:	// show char immediate
				SkipEL(1)
				endcase
			case #364:	// set space x
			case #365:	// set space y
				SkipEL(2)
				endcase
			case #366:	// reset space
			case #367:	// space
				endcase
			case #370:	// brightness
			case #371:	// hue
			case #372:	// saturation
				SkipEL(1)
				endcase
			case #373:	// show objects
				objectsfound = true
				SkipDL(GetELWord() lshift 1)
				endcase
			case #374:	// show dots
			case #375:	// show dots
				DoShowDots()
				endcase
			case #376:	// rectangle
				SkipEL(4)
				endcase
			case #377:	// noop
				endcase
			default:	Error("unknown entity command")
				endcase
				]
			]
		test objectsfound
		ifso if pass eq arrowpass then
			ep>>EH.dstart1 = ep>>EH.dstart1 % #100000
				// set bit where it's always zero
		ifnot	// can fix entity
		test pass eq arrowpass
		ifso		// save min values
			[
			ep>>EH.width = xright - xMin	// fix it
			ep>>EH.height = ytop - yMin	// fix it
			ep>>EH.xleft = xMin - ep>>EH.xe		// temp storage
			ep>>EH.ybottom = yMin - ep>>EH.ye
			]
		ifnot
			[
			ep>>EH.xe = ep>>EH.xe + ep>>EH.xleft
			ep>>EH.ye = ep>>EH.ye + ep>>EH.ybottom
			ep>>EH.xleft = 0
			ep>>EH.ybottom = 0
			]
		]
	]

and
let GetELByte() = valof
	[
	let b = elByte eq 0 ? @elWord rshift 8 , @elWord & #377
	elByte = 1 - elByte
	if elByte eq 0 then elWord = elWord + 1
	resultis b
	]

and
let GetELWord() = (GetELByte() lshift 8) % GetELByte()

and
let PutBackELWord(w) be
	[
	elWord = elWord - 1
	PutBackELByte(w rshift 8)
	PutBackELByte(w & #377)
	]

and
let PutBackELByte(b) be
	[
	@elWord = (@elWord & (elByte eq 0 ? #377, #177400)) %
		(elByte eq 0 ? b lshift 8, b)
	elByte = 1 - elByte
	if elByte eq 0 then elWord = elWord + 1
	]

and
let SkipEL(bytes) be
	for i = 1 to bytes do GetELByte()

and
let SkipDL(bytes) be
if pressPass eq arrowpass then
	[
	if bytes ls 0 then
		[
		let v = vec 1
		let bignum = vec 1
		bignum!0 = 0
		bignum!1 = #100000
		FilePos(InputByteStream, v)
		DoubleAdd(v, bignum)
		SetFilePos(InputByteStream, v)
		bytes = bytes & #77777
		]
	for i = 1 to bytes do Gets(InputByteStream)
	]

and
let GetDLString(v, bytes) =
pressPass eq xypass? v, valof
	[
	v!0 = 0
	for i = 1 to bytes do AppendChar(v, Gets(InputByteStream))
	resultis v
	]

and
let DoShowString(str, elcode, backup) be
if pressPass eq arrowpass & nth(str, 0) ge 5 then
	[
	let v = vec 30
	v!0 = 0
	for i = 1 to 4 do AppendChar(v, nth(str, i))
	if EqStr(v, "<==<") then
		[
		v!0 = 0
		for i = 5 to nth(str, 0) do
			[
			if nth(str, i) eq $< then break
			if nth(str, i) ne $*s then AppendChar(v, nth(str, i))
			]
		if nIllus eq maxIllus then
			Error("too many illustrations in files.")
		let p = mergeList + nIllus*MERGElen
		p>>MERGE.file = MergeFileNo(v)
		p>>MERGE.x = pressX
		p>>MERGE.y = pressY
		nIllus = nIllus + 1
		if p>>MERGE.file eq -2 then return		// not found
			// now fix EL
		elWord = elWord - ((backup+1) rshift 1)		// backup words
		if (backup&1) ne 0 then GetELByte()		// skip byte
		PutBackELByte(elcode)
		for i = 2 to backup do GetELByte()		// return to place
		]
	]

and
let DoSetX(x, eh, movexy) be
	// if movexy false, do nothing
if movexy then test pressPass eq arrowpass
ifso
	[
	pressX = x + eh>>EH.xe
	xMin = min(pressX, xMin)
	]
ifnot PutBackELWord(x - eh>>EH.xleft)

and
let DoSetY(y, eh, movexy) be
	// if movexy false, do nothing
if movexy then test pressPass eq arrowpass
ifso
	[
	pressY = y + eh>>EH.ye
	yMin = min(pressY - chardrop, yMin)
	]
ifnot PutBackELWord(y - eh>>EH.ybottom)

and
let DoShowDots() be
	[
	let ub = GetELWord()
	if ub ne 0 then Error("huge dots")
	let lb = GetELWord()
	SkipDL(lb)
	SkipDL(lb)
	]

// Similar to SetupEntityList in presseditpage
// set up list of entities by reading from file
// pdv is pointer to part-dir entry
// evec is vector of entity lengths, stored in reverse order
// returns no of entities

and SetupEntities(pdv, evec, os, vecaddress) = valof [

	if pdv>>PD.precs eq 0 then resultis 0	// empty page
	let startrec=pdv>>PD.pstart		// set offset
	let trecs = pdv>>PD.precs & #177600	// nearest 200
	let w=((pdv>>PD.precs & #177) lshift 8)-pdv>>PD.padding-1
	let wMinusWStart=0
//	let wstart = w
	let ec=0
	evec!0 = vecaddress	// in case 0 ents
	[eloop
		if w ls 0 then
			[
			trecs = trecs - #200
			w = w + (#200 lshift 8)
			]
		let l=PGread(startrec + trecs, w)	// get length
		if l eq 0 then break	// done
		evec!ec=wMinusWStart		// address rel to wstart
		ec=ec+1
		if ec ge MaxEntities then Error("too many entities")
		w=w-l
		wMinusWStart=wMinusWStart-l
		]eloop repeat
	if ec eq 0 then resultis 0
	for i = 0 to ec - 1 do
		evec!i = vecaddress + evec!i - wMinusWStart - EHlen
		// actual address
	PositionPage(InputStream, startrec + trecs + (w rshift 8) + 1)
	PositionPtr(InputStream, (w & #377)*2 + 2)	// past zero wd
	if vecaddress-wMinusWStart ge EntVec+(MaxEntBytes/2) then
		Error("Too many bytes of entities on one page")
	ReadBlock(InputStream, vecaddress, 0 - wMinusWStart)	// read EL
	let ep = evec!0		// ptr to last entity in EL
		// make DL end on word boundary
	let dlw=vec 1
	if ((ep>>EH.dstart2 + ep>>EH.dlength2) & 1) ne 0 then
		DoubleAdd(lv ep>>EH.dlength1, table [ 0;1 ] )
	dlw!0=ep>>EH.dstart1; dlw!1=ep>>EH.dstart2
	DoubleAdd(dlw, lv ep>>EH.dlength1)
	PositionPage(InputStream,startrec+1)
	CopyPages(os,(dlw!1 rshift 9)+(dlw!0 lshift 7))		// copy pages of DL
	CopyWords(os,(dlw!1 rshift 1)&#377)		// rest of DL
	resultis ec
	]

and
let SetUpMergeDD(ddv, fdlength) be
	[
	ddv>>DD.pressfile = true
	ddv>>DD.nrecs = OutDocDir>>DDV.nrecs
	ddv>>DD.nparts = OutDocDir>>DDV.nparts
	ddv>>DD.npages = OutDocDir>>DDV.nparts - 1
	ddv>>DD.pdstart = OutDocDir>>DDV.pdstart
	ddv>>DD.fdstart = OutDocDir>>DDV.pdstart - fdlength
	ddv>>DD.pdrecs = OutDocDir>>DDV.pdrecs
	ddv>>DD.fdrecs = fdlength
	ddv>>DD.nsets = 0
	ddv>>DD.pref = 0
	]