// bcpl/f PressEditPage.bcpl
// press edit page output

// Last edited by Lyle Ramshaw January 13, 1982  3:38 PM
// Last edited by RML August 12, 1980  1:56 PM
// RML June 25, 1979  11:46 AM
// rotated fonts

// Copyright Xerox Corporation 1979, 1980, 1982

get "presseditdefs.bcpl"
get "streams.d"
get "AltoFileSys.d"
get "time.d"

// outgoing procedures

external [
	CopyPressPage
	CopyPages
	CopyWords
	FixPartDir
	PGread
	PutPrivateDL
	PutPrivateEL
	PutPadding
	ReadExternalFileDir
	WriteExternalFileDir
	WritePressPages
	WriteFontDir
	WritePartDir
	WriteDocDir
	]

// outgoing statics

external
	[
	OutPartDirPtr
	]

static [
	OutPartDirPtr
	]

// incoming procedures

external [
	BlankSet
	CompareSets
	CheckFontEntry
//	ConvertEarsPage
	CopyString
	DecodeFontName
	EqStr
	EqChar
	IsPressFile
	Resets
	ReadPressPageDir
	PressMergeScan
	FontFlag
	IsNumber
	IsDigit
	GetFileLength
	WFACE
	AppendFace
	SetInFile
	Error
	FileError
	nth
	pnth
	utilinit
	radixconvert
	max
	min
	AppendChar
	FilePage
	UNPACKDT
	CONVUDT
	OpenFile
	Gets
	Puts
	Closes
	Ws
	FileLength
	PositionPage
	PositionPtr
	MoveBlock
	Zero
	ReadCalendar
	DoubleAdd
	FilePos
	GetFixed
	FixedLeft
	FreeFixed
	WriteBlock
	ReadBlock
	Wns
	]

// incoming statics

external [
	DLByteCount
	DocDirList
	docMergePtrs
	dsp
	efCount
//	EarsFontSets
	EntByteCount
	EntVec
	FamilyDir
	FileNames
	FontSets
	illusMergePtrs
	InputStream
	InputByteStream
	MaxSet
	Merge
	mergeList
	mergePtr
	NPages
	NFiles
	nIllus
	PageList
	PageDir
	PageDirFile
	PrivateStamp
	OutPartDir
	OutDocDir
	pageNoStart
	pageNoX
	pageNoY
	pageNoOmit
	SetMapTable
	UserName
	]

manifest [
	toppage=100+10*2540
	bottompage=200
	stampx=7*2540
	]

structure PS: [
	esetx	bit 8
	xl	bit 8
	xr	bit 8
	esety	bit 8
	y	word
	efont	bit 4
	font	bit 4
	showc	bit 8
	]

manifest [ PSlen=size PS/16 ]

structure RCT: [
	esetx	bit 8
	xl	bit 8
	xr	bit 8
	esety	bit 8
	y	word
	erect	word
	w	word
	h	word
	]

manifest [ RCTlen=size RCT/16 ]

// if there is an External file directory, read it and dump it to 
// a disk file.

let ReadExternalFileDir(s,fn,outS) be [
	let ddv=DocDirList+fn*DDlen
	if ddv>>DD.efdstart eq 0 then return	// there isn't one.
	SetInFile(s,ddv,ddv>>DD.efdstart,0)
	efCount=efCount+TransferExternalFileDir(s,outS)
	]

and WriteExternalFileDir(inStr, outStr)=valof [
	Puts(inStr,0)	// Terminate the scratch file
	Resets(inStr)
	if efCount eq 0 then resultis 0
	unless efCount eq TransferExternalFileDir(inStr,outStr) do Error("External File Directory error")
	Puts(outStr,0)	// Terminate Dir
	efCount=efCount+1
	resultis AddPart(2,PadOut(outStr,efCount))
 	]

and TransferExternalFileDir(inStr,outStr)=valof [
	let count=0
	let t=Gets(inStr)
	until t eq 0 do [
	let wdLength=t<<STRING.length/2+1
	for i=1 to wdLength do [
		Puts(outStr,t); t=Gets(inStr)]
	count=count+wdLength
	]
	resultis count
	]

and  AddPart(type,nwds) = valof [
	Zero(OutPartDirPtr, PDlen)
	OutPartDirPtr>>PD.type=type
	OutPartDirPtr>>PD.pstart=NextPartRec(OutPartDirPtr)
	OutPartDirPtr>>PD.precs=nwds rshift 8
	OutPartDirPtr=OutPartDirPtr+PDlen
	resultis nwds rshift 8
	]

and WritePressPages(os) be [
	let npart=0		// page 0
	let openfile=-1		// none open
	let firstfile = true
	nIllus = 0
	InputStream=0
	InputByteStream=0
	OutPartDirPtr=OutPartDir
	if NPages eq 0 then [
		WriteBlankPage(os)
		return
		]
	if PrivateStamp eq $P then
		[
		let pnomit = pageNoOmit + 1
		Ws("*nNumbering pages from ")
		Wns(dsp, pageNoStart)
		Ws(", starting on ")
		Wns(dsp, pnomit)
		let prem = pnomit rem 10
		Ws(prem eq 1 ? "st", prem eq 2? "nd", prem eq 3? "rd", "th")
		Ws(" page")
		]
	for x=0 to NPages-1 do [		// each entry in PageList
		let fn=(PageList+x)>>PAGE.filename
		let pn=(PageList+x)>>PAGE.pageno
		let lpn=pn	// if last page=first
		let ddv=DocDirList+fn*DDlen
		if fn ne openfile then [
			Puts(dsp, $*N); Ws(FileNames!fn); Puts(dsp, $:)
			if openfile ne -1 then
				[ Closes(InputStream); firstfile = false ]
			if InputByteStream ne 0 then
				Closes(InputByteStream)
			InputStream=OpenFile(FileNames!fn, ksTypeReadOnly)
			InputByteStream=  IsPressFile(fn) ne 0 & 
				Merge eq 0 ? 0, OpenFile(FileNames!fn, ksTypeReadOnly, charItem)
			openfile=fn
			]
		if fn ne PageDirFile then
			ReadPressPageDir(InputStream,fn)
		if pn eq #377 then [ pn=1; lpn=ddv>>DD.npages ]
		for pgno=pn to lpn do
			[
			let mp = nil
			if Merge then
				[
				mergePtr = firstfile? docMergePtrs + pgno - 1,
					illusMergePtrs + fn 
				mp = mergeList + nIllus*MERGElen
					// pointer to first entry for page
				@mergePtr = mp
				@(mergePtr+1) = 0	// terminates list
				]
			let oldnillus = nIllus
			if WritePressPage(pgno-1,os,fn) then [
				npart=npart+1
				Puts(dsp, $*S); Wns(dsp, pgno)
				]
			if (Merge eq $A) & (firstfile eq false) then
				[
				mp>>MERGE.file=fn;  mp>>MERGE.x=0;  mp>>MERGE.y=0
				nIllus = nIllus+1 
				mp = mergeList + nIllus*MERGElen
				mp>>MERGE.file=npart-1;  mp>>MERGE.x=0;  mp>>MERGE.y=0
				nIllus = nIllus+1 
				@mergePtr = mp
				@(mergePtr+1) = mergeList + nIllus*MERGElen
				]
			if Merge eq $M then
				[
				if nIllus eq oldnillus then @mergePtr = 0	// no figs 
				if nIllus ne oldnillus & firstfile eq false then
					mp>>MERGE.file = npart - 1
						// put part no in MERGE structure 
				@(mergePtr+1) = mergeList + nIllus*MERGElen
					// pointer to next free entry terminates list
				@(mergePtr+2) = -1	// followed by -1
				]
			]
		]
	Closes(InputStream)
	if InputByteStream ne 0 then Closes(InputByteStream)
	]

and WriteBlankPage(os) be [

	for i=1 to 256 do Puts(os, 0)
	Zero(OutPartDirPtr, PDlen)
	OutPartDirPtr>>PD.type=0
	OutPartDirPtr>>PD.pstart=0
	OutPartDirPtr>>PD.precs=1
	OutPartDirPtr>>PD.padding=255
	OutPartDirPtr=OutPartDirPtr+PDlen
	]

and WritePressPage(pn,os,fn) = valof [

	let ddv=DocDirList+fn*DDlen
	let pv=FindPart(pn,ddv)
	if pv eq 0 then resultis false
	test IsPressFile(fn)
	ifso [
		test SetMapTable!fn eq 0 & PrivateStamp eq 0 & Merge eq 0
		ifso CopyPressPage(os,pv,ddv)
		ifnot MapPressPage(os,pv,SetMapTable!fn,ddv)
		]
	ifnot [
		Error(fn, "Not a Press File")
//		ConvertEarsPage(ddv,pv,os,fn,EarsFontSets!pn)
//		let wp=PutPadding(os)
//		FixPartDir(wp,os)
		]
	resultis true
	]

// copy page, no font set mapping

and CopyPressPage(os,pv,ddv) be [

	SetInFile(InputStream,ddv,pv>>PD.pstart,0)
	CopyPages(os,pv>>PD.precs)
	FixPartDir(pv>>PD.padding,os)
	]

and MapPressPage(os,pv,mp,ddv) be [

	let evec=vec MaxEntities-1
	let bc=vec 1		// for file posn
	FilePos(os,bc)		// at start
	let entcount=SetupEntityList(pv,evec,os,ddv)
	if PrivateStamp ne 0 then PutPrivateDL(os,bc)
	let entptr = EntVec
	for i=entcount-1 to 0 step -1 do [
		if entptr + evec!i - EntVec - MaxEntBytes/2 gr 0 then
			Error("page is too complex")
		ReadBlock(InputStream, entptr, evec!i - EHlen)
		entptr = entptr + evec!i - EHlen
		ReadBlock(InputStream, entptr, EHlen)
		if mp ne 0 then		// mapped set 
			entptr>>EH.fontset=mp!(entptr>>EH.fontset)
		entptr = entptr + EHlen
		]
	if Merge eq $M then PressMergeScan(evec, entcount, entptr, pv)
	WriteBlock(os, EntVec, entptr - EntVec)
	if PrivateStamp ne 0 then PutPrivateEL(os,bc)
	let pw=PutPadding(os)
	FixPartDir(pw,os)
	]

and PutPadding(s) = valof [

	let wp=(FilePos(s) rshift 1)&#377
	if wp eq 0 then resultis 0
	for i=wp to 255 do Puts(s, 0)
	resultis 256-wp
	]

and PutPrivateDL(os,bc) be [

	let tc=vec 1
	MoveBlock(tc,bc,2)	// move start to tc
	FilePos(os,bc)
	DoubleSubtract(bc,tc)
	test PrivateStamp eq $P
	ifso
		[
		let pageno = (OutPartDirPtr - OutPartDir)/PDlen
		if pageno ge pageNoOmit then
			[
			pageno = pageno - pageNoOmit + pageNoStart
			let t = "*s*s*s*s*s"
			let pns = vec 4
			MoveBlock(pns, t, 3)
			let ns = vec 6
			ns!0 = 0
			radixconvert(ns, pageno, 10)
			for i = 1 to nth(ns, 0) do
				pnth(pns, 5 - nth(ns, 0) + i, nth(ns, i))
			WriteBlock(os, pns+1, 2)
			]
		]
	ifnot
		[
		let t=" XeroxPrivateDataA"
		WriteBlock(os, t+1, 9)
		]
	Puts(os, 0)		// end DL
	]

and DoubleSubtract(a,b) be [

	let one=table [ 0; 1 ]
	let v=vec 1
	v!0=not b!0
	v!1=not b!1
	DoubleAdd(v,one)
	DoubleAdd(a,v)
	]

and PutPrivateEL(s,bc) be
test PrivateStamp eq $P
ifso if (OutPartDirPtr - OutPartDir)/PDlen ge pageNoOmit then
	[
	let wc=PutString(s,pageNoX,pageNoY,4,0,0)
	let eh=table [ 0; 0; 0; 0; 4; 0; 0; 0; 0; 0; 0; 0 ]
	if SetMapTable!(NFiles-1) ne 0 then
		eh>>EH.fontset=@(SetMapTable!(NFiles-1))
	MoveBlock(lv eh>>EH.dstart1,bc,2)
	eh>>EH.length=wc+EHlen
	WriteBlock(s, eh, EHlen)
	]
ifnot
	[
	let stampy=PrivateStamp eq $T ? toppage, bottompage
	let wc=PutString(s,stampx+1500,stampy+1200,5,0,0)
	wc=PutString(s,stampx+1500,stampy+850,7,0,wc)
	wc=PutString(s,stampx+1500,stampy+500,4,0,wc)
	wc=PutString(s,stampx,stampy,1,1,wc)    // wc keeps word count
	wc=PutBox(s,stampx-100,stampy+250,stampx+2840,stampy+1680,wc)
	wc=PutBox(s,stampx-250,stampy+100,stampx+2990,stampy+1830,wc)
	let eh=table [ 0; 0; 0; 0; 17; 0; 0; 0; 0; 0; 0; 0 ]
	if SetMapTable!(NFiles-1) ne 0 then
		eh>>EH.fontset=@(SetMapTable!(NFiles-1))
	MoveBlock(lv eh>>EH.dstart1,bc,2)
	eh>>EH.length=wc+EHlen
	WriteBlock(s, eh, EHlen)
	]

and PutString(s,x,y,nc,f,wc) = valof [

	let t=table [ ESetX lshift 8; ESetY; 0; EFont lshift 8 ]
	t>>PS.xl=x rshift 8
	t>>PS.xr=x&#377
	t>>PS.y=y
	t>>PS.font=f
	t>>PS.showc=nc-1
	WriteBlock(s, t, PSlen)
	resultis wc+PSlen
	]

and PutBox(s,x1,y1,x2,y2,wc) = valof [

	let w=PutRect(s,x1-20,y1-20,x2-x1+40,40,wc)
	w=PutRect(s,x1-20,y1-20,40,y2-y1+40,w)
	w=PutRect(s,x1-20,y2-20,x2-x1+40,40,w)
	w=PutRect(s,x2-20,y1-20,40,y2-y1+40,w)
	resultis w
	]

and PutRect(s,x,y,w,h,wc) = valof [

	let t=table [ ESetX lshift 8; ESetY; 0; (ENop lshift 8)+ERect; 0; 0 ]
	t>>RCT.xl=x rshift 8
	t>>RCT.xr=x&#377
	t>>RCT.y=y
	t>>RCT.w=w
	t>>RCT.h=h
	WriteBlock(s, t, RCTlen)
	resultis wc+RCTlen
	]

and FixPartDir(pw,s) be [

	let opv=OutPartDirPtr
	Zero(opv, PDlen)	// zero any unset bits
	opv>>PD.type=0
	opv>>PD.pstart=NextPartRec(opv)
	opv>>PD.precs=FilePage(s)-opv>>PD.pstart
	opv>>PD.padding=pw
	OutPartDirPtr=OutPartDirPtr+PDlen
	]

// 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
// copies DL

and SetupEntityList(pdv,evec,os,ddv) = valof [

	if pdv>>PD.precs eq 0 then resultis 0	// empty page
	let startrec=pdv>>PD.pstart		// set offset
	if startrec ge ddv>>DD.nrecs then Error("bad page address")
	let trecs = pdv>>PD.precs & #177600	// nearest 200
	let w=((pdv>>PD.precs & #177) lshift 8) - pdv>>PD.padding-1
	let ec=0
	[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=l
		ec=ec+1
		if ec ge MaxEntities then Error("too many entities")
		w=w-l
		]eloop repeat
	PositionPage(InputStream, startrec+1)
	CopyPages(os, trecs)		// copy pages of DL
	CopyPages(os,w rshift 8)		// copy more pages of DL
	CopyWords(os,(w&#377)+1)		// rest of DL, zero word
	resultis ec
	]

and CopyPages(os,np) be [

	let pagebuffersize=(FixedLeft()-1000)/256	// no of pages
	if pagebuffersize le 0 then Error("no room to copy pages")
	let pagebuffer=GetFixed(pagebuffersize lshift 8)
	let i=0
	until i ge np do [
		let pc=min(pagebuffersize,np-i)
		let wc=pc lshift 8
		ReadBlock(InputStream,pagebuffer,wc)
		WriteBlock(os,pagebuffer,wc)
		i=i+pc
		]
	FreeFixed(pagebuffer)
	]

and CopyWords(os,nw) be [

	for i=1 to nw do Puts(os, Gets(InputStream))
	]

and PGread(pn,wn) = valof [

	PositionPage(InputStream,pn+(wn rshift 8)+1)
	PositionPtr(InputStream, (wn&#377)*2)
	resultis Gets(InputStream)
	]

and FindPart(pn,ddv) = valof [

	let count=0
	for i=0 to ddv>>DD.nparts-1 do [
		let p=PageDir+i*PDlen
		if p>>PD.type eq 0 then [
			if count eq pn then resultis p
			count=count+1
			]
		]
	resultis 0
	]

and WriteFontDir(os) = valof [

	let fev=vec FElen-1
	let nw=0		// word count
	for i=0 to MaxSet do [
		let fp=FontSets+16*i
		unless BlankSet(fp) then for j=0 to 15 do [
			let p=fp!j
			if p ne 0 then [
				Zero(fev, FElen)
				fev>>FE.length=FElen
				fev>>FE.set=i
				fev>>FE.fno=j
				fev>>FE.destn=255
				let famp=FamilyDir+FamilyLen*
					p>>FONT.family
				MoveBlock(lv fev>>FE.fam, famp, FamilyLen)
				fev>>FE.face=p>>FONT.face
				fev>>FE.siz=p>>FONT.ptsize
				fev>>FE.rotn=p>>FONT.rotn

				WriteBlock(os, fev, FElen)
				nw=nw+FElen
				]
			]
		]
	Puts(os, 0)
	nw=nw+1
	resultis AddPart(1,PadOut(os,nw))
	]

and PadOut(os,wds) = valof [
	until (wds & #377) eq 0 do [
		Puts(os, 0)
		wds=wds+1
		]
	resultis wds
	]


and WritePartDir(os) be [

	let nw=OutPartDirPtr-OutPartDir
	OutDocDir>>DDV.nparts=nw/PDlen
	if (nw&#377) ne 0 then nw=(nw&#177400)+256
	WriteBlock(os, OutPartDir, nw)
	OutDocDir>>DDV.pdrecs=nw rshift 8
	let pds=NextPartRec(OutPartDirPtr)
	OutDocDir>>DDV.pdstart=pds
	OutDocDir>>DDV.nrecs=pds+(nw rshift 8)+1
	]

and WriteDocDir(os,ofn) be [

	OutDocDir>>DDV.passwd=PressPassword
	ReadCalendar(lv OutDocDir>>DDV.date1)	// insert date
	let tvec = vec lenUTV-1
	UNPACKDT(lv OutDocDir>>DDV.date1, tvec)	// unpack date, time
	let timestring = vec 15
	CONVUDT(timestring, tvec, true)	// print zone
	Zero(OutDocDir+#200, #200)
	MoveBlock(OutDocDir+#200,ofn,StringWords(ofn))
	MoveBlock(OutDocDir+#232,UserName,StringWords(UserName))
	MoveBlock(OutDocDir+#252,timestring,StringWords(timestring))
	WriteBlock(os, OutDocDir, 256)
	]

and StringWords(s) = (nth(s,0) rshift 1) + 1

and NextPartRec(opv) = (opv eq OutPartDir ? 0, (opv-PDlen)>>PD.pstart +
				(opv-PDlen)>>PD.precs)
(635)\1064v12V