// bcpl/f PressEditFonts.bcpl -- merge, page edit press files
// Copyright Xerox Corporation 1979, 1980, 1981, 1982

// Last modified by Lyle Ramshaw on January 13, 1982  4:02 PM
// Last modified by Lyle Ramshaw on January 14, 1981  10:53 AM
// Last modified by RML on August 5, 1980  4:45 PM
// renamed 1.83

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

// outgoing procedures

external [
	AddExtraFonts
	AddExtraFont
	FindFamily
	InitializeFonts
	LookupFamily
	MakeFontEntry
	MatchFontSets
	PrintFontSets
	ReadFontNames
	ReadPressFontDir
	ScanFontSets
	]

// incoming procedures

external [
	BlankSet
	CheckFontEntry
	CompareSets
	DecodeFontName
	EqStr
	Error
	Gets
	GetFixed
	max
	MoveBlock
	OpenFile
	Puts
	ReadBlock
	SetInFile
	WFACE
	Wns
	Ws
	Wl
	Zero
	]

// incoming statics

external
	[
	Debug
	DocDirList
	docMergePtrs
	DLByteCount
	dsp
	efCount	
	efScratch	// dump of external files
	EntVec
	EntByteCount
	ExtraFonts
	FamilyDir
	FileNames
	FontSets
	FontVec
	FontVecPtr
	illusMergePtrs
	InputStream
	InputByteStream
	MaxSet
	Merge
	mergeList
	mergePtr
	NFamilies
	NFontEntries
	NPages
	NFiles
	nIllus
	NRects
	OutPartDir
	OutDocDir
	OutputFileName
	PageList
	PageDir
	PageDirFile
	pageNoStart
	pageNoX
	pageNoY
	pageNoOmit
	PrivateStamp
	RectangleVec
	SetMaps
	SetMapPtr
	SetMapTable
	TempSets	
	TLvec
	XFonts
	]

let ReadFontNames(fd) be [

	Zero(fd, MaxFamilies*FamilyLen)	// zero it out
	NFamilies=0		//so far
	]

and FindFamily(s) = valof [

	for i=0 to NFamilies-1 do
		if FamilyDir!(i*FamilyLen) ne 0 then
		    if EqStr(s,FamilyDir+i*FamilyLen) then resultis i
	if NFamilies ge MaxFamilies then 
		Error("Too many font family names")
	let curFams=NFamilies
	MoveBlock(FamilyDir+curFams*FamilyLen,s,FamilyLen)
	NFamilies=curFams+1
	resultis curFams
	]

// check validity of all files, Press or Ears



// read Press font directory
// SetMapTable contains one ptr per file, pointing into SetMaps
// ptr is zero if no mapping needed
// in SetMaps is set of new font set nos (ddv>>DD.nsets entries)
// FontSets contains up to 64 lists of 16 pointers to FONT entries
// FONT entries are stored in FontVec
// while assembling sets for one file, use TempSets

and InitializeFonts() be [

	FontVecPtr=FontVec
	Zero(FontSets, 1024)
	MaxSet=-1
	SetMapPtr=SetMaps
	]

and ReadPressFontDir(s,fn) be [

	let ddv=DocDirList+fn*DDlen
	SetInFile(s,ddv,ddv>>DD.fdstart,0)
	let evec=vec FElen-1	// vector for entry
	Zero(TempSets, 1024)
	let maxfontset=0

	[
	ReadBlock(s, evec, FElen)	// read it
	if evec>>FE.length eq 0 then break
	CheckFontEntry(evec)
	let fp=MakeFontEntry(evec,FontVecPtr)
	if fp eq FontVecPtr then FontVecPtr=FontVecPtr+FONTlen
	if FontVecPtr-FontVec ge FONTlen*MaxFonts then
		Error("too many different fonts")
	TempSets!(16*evec>>FE.set+evec>>FE.fno)=fp
	maxfontset=max(maxfontset,evec>>FE.set)
	] repeat

	MatchFontSets(fn,maxfontset)
	]

and MatchFontSets(fn,maxfontset) be [

	SetMapTable!fn=SetMapPtr
	let mapsame=true
	for i=0 to maxfontset do [
	    SetMapPtr!i=-1		// in case blank set
	    let tp=TempSets+16*i
	    unless BlankSet(tp) then [
		let s=ScanFontSets(tp)
		SetMapPtr!i=s
		if s ne i then mapsame=false	// need map
		]
	    ]
	test mapsame
	ifso SetMapTable!fn=0
	ifnot SetMapPtr=SetMapPtr+maxfontset+1
	(DocDirList+fn*DDlen)>>DD.nsets=maxfontset+1
	]

// returns font set no, makes new entry if necessary

and ScanFontSets(tp) = valof [

	for j=0 to MaxSet do [
	    let fp=FontSets+16*j
	    unless BlankSet(fp) then [
		switchon CompareSets(fp,tp) into [
			case 0: case 1:	resultis j
			case 2:		// old is subset of new
			  MoveBlock(fp, tp, 16)
			  resultis j
			case 3:		// combine them
			  for i=0 to 15 do if fp!i eq 0 then fp!i=tp!i
			  resultis j
			default: endcase	// not same
			]
		]
	    ]
	MaxSet=MaxSet+1
	MoveBlock(FontSets+16*MaxSet, tp, 16)
	resultis MaxSet
	]

// find entry matching this font, or make new entry
// returns pointer to entry

and MakeFontEntry(ev,fp) = valof [

	let fam=FindFamily(lv ev>>FE.fam)
	fp>>FONT.family=fam
	fp>>FONT.face=ev>>FE.face
	fp>>FONT.ptsize=ev>>FE.siz
	fp>>FONT.rotn=ev>>FE.rotn
	fp>>FONT.earsfont=false	// in all new entries
	let p=FontVec
	until (p!0 & #77777) eq (fp!0 & #77777) & (p>>FONT.face eq fp>>FONT.face) & (p>>FONT.ptsize eq fp>>FONT.ptsize) & (p>>FONT.rotn eq fp>>FONT.rotn) do
							p=p+FONTlen
	resultis p		// points to new entry
	]

and PrintFontSets() be [

	Wl("Font sets:")
	for s=0 to MaxSet do [
		let blankfont=true
		let p=FontSets+16*s
		Wns(dsp, s); Ws(": ")
		for j=0 to 15 do if p!j ne 0 then [
			let fp=p!j
			Ws(FamilyDir+(fp>>FONT.family)*FamilyLen)
			Wns(dsp, fp>>FONT.ptsize)
			WFACE(fp>>FONT.face)
			unless fp>>FONT.rotn eq 0 do 
				[
				Puts(dsp, $()
				Wns(dsp, fp>>FONT.rotn)	
				Puts(dsp, $))
				]
			Puts(dsp, $(); Wns(dsp, j); Ws(") ")
			blankfont=false
			]
		if blankfont then Ws(" not used")
		Puts(dsp, $*n)
		]
	]

and AddExtraFonts() be [

	for i=0 to XFonts-1 do [
		let s=ExtraFonts!i
		DecodeFontName(s,FontVecPtr)
		let p=FontVec
		until p!0 eq FontVecPtr!0 & (p>>FONT.face eq FontVecPtr>>FONT.face) & (p>>FONT.ptsize eq FontVecPtr>>FONT.ptsize) do
			p=p+FONTlen
		if p eq FontVecPtr then [
			FontVecPtr=FontVecPtr+FONTlen
			if FontVecPtr-FontVec ge FONTlen*MaxFonts then
				Error("too many different fonts")
			AddExtraFont(p)
			]
		]
	NFontEntries=(FontVecPtr-FontVec)/FONTlen
	]

and AddExtraFont(fp) be [

	for fn=0 to MaxSet do [
		let p=FontSets+16*fn
		unless BlankSet(p) then
			for i=0 to 15 do if p!i eq 0 then [
				p!i=fp
				return
				]
		]
	MaxSet=MaxSet+1
	if MaxSet gr 63 then Error("too many font sets")
	FontSets!(16*MaxSet)=fp	// start new set with this one
	]