// D I R  (Press and font file directory processing) 
//  errors 600
//
//

get "Spruce.d"
get "SpruceFiles.d"
get "PressFile.d"
get "Streams.d"

// outgoing procedures
external
	[
	OpenUp
	OpenForFonts
	CloseDown
	PressDirectories
	FEEnter
	FEEnterLiteral
	FontPass
	UseEntry	// finds font set, font value corresponding to index
	]

// incoming procedures
external
	[
//SPRUCE
	SpruceError
	SpruceCondition
	DblShift
	FSGetX
	FSPut

//PARTS
	SetPartBounds
	GetPositioninPart
	SetPositioninPart
	SetBytePositioninPart
	SkipinPart

//WINDOW,FILES
	GetSprucePage
	PutSprucePage
	WindowCreateStream
	WindowClose
	WindowGetPosition
	WindowSetPosition
	WindowReadBlock
	WindowWriteBlock	
	WindowRead
	WindowWrite
	WindowFlush
	FileLeng
	InitSpruceFile
	ResetSpruceFile

//CURSOR
	CursorChar
	CursorDigit

//OS
	Zero
	MoveBlock

//SPRUCEML
	DoubleAdd; DoubleSub; DoubleCop; MulDiv
	MulFull

	DisableComments
	FillInNames
	Ugt
	]

// incoming statics
external
	[
	Capabilities
	ResolutionS; ResolutionB
	FontFile; BandFile
	FontWindow; BandWindow
	DPzero
	LogoFont
	breakPage
	LandscapeDevice
	SpruceZone
	]

// internal statics
static
	[
	bestBreakFont
	]

// File-wide structure and manifest declarations.

// Definitions for reading font files (see FontFormats)

structure IXH :
 [
	Type	bit 4
	Length	bit 12
 ]

structure IXN :
 [
	@IXH
	Code	word
	Name	word 10
 ]

structure IX :
 [
	@IXH				//Header, type = IXTypeChars or IXTypeOrbitChars
	fam	byte			//Family number
	face	byte			//Face code
	bc	byte			//First char number
	ec	byte			// and last
	siz	word			// Size in microns
	rotation word			// Rotation in minutes
	sa	word 2			// Starting position in file
	len	word 2			// and length
	resolutionx	word		// 10* number of bits/inch
	resolutiony	word
 ]

structure IXM :
 [
	@IXH				//Header, type = IXTypeMultiChars
	fam	byte			//Family number
	face	byte			//Face code
	bc	byte			//First char number
	ec	byte			// and last
	siz	word			// Size in microns
	rotation word			// Rotation in minutes
	resolutionx	word		// 10* number of bits/inch
	resolutiony	word
	numSegs word			// number of character width segments (1st contains rasters)
	segs^1,4: [			// Max 4
		sa word 2		// starting position in file
		len word 2		// and length
		date word 2 =		// date after which these widths are no longer valid
		  [ date0 word; date1 word ]
		]
 ]

manifest [
//IXH types
	IXTypeEnd=0
	IXTypeName=1
	IXTypeChars=3
	IXTypeOrbitChars = 5
	IXTypeMultiChars = 6

//length to allocate
	IXLMax= (size IXM)/16

	HI1174 = #104517 rshift 1 // 104517,,65200 is January 1, 1974 (for range test)
	HI123189 = #123546 rshift 1 // 123546,,113400 is December 31, 1989
 ]

manifest [ // Buffer strategy values for files managed here
	nbfPressFile = 10 // ~~ M31 only, for now!! nbf... is "number of buffers for ..."
	ncbPressFile = 8 // ncb... is "number of cbs for ..."
	nahEL = -3 // nah... is "number of pages to stay ahead for ..."
	nahDL = 5

	nbfFontFile = 6
	ncbFontFile = 5
	nahFontWindow = 5

	nbfBandFile = 10
	ncbBandFile = 5
	nahBandWindow = 4 // output ahead value
	]

// Procedures

let OpenUp(pDoc) be
[
	let PressFile=pDoc>>DocG.PressFile
	Zero(lv pDoc>>DocG.nFontLoads,lenDocG-(offset DocG.nFontLoads/16))
	InitSpruceFile(PressFile, nbfPressFile, ncbPressFile)
	pDoc>>DocG.EL=WindowCreateStream(PressFile, ksTypeReadOnly, wordItem, nahEL)
	pDoc>>DocG.DL=WindowCreateStream(PressFile, ksTypeReadOnly, wordItem, nahDL)
	InitSpruceFile(FontFile, nbfFontFile, ncbFontFile)
	FontWindow=WindowCreateStream(FontFile, ksTypeReadOnly, wordItem, nahFontWindow)
	InitSpruceFile(BandFile, nbfBandFile, ncbBandFile)
	PutSprucePage(BandFile, GetSprucePage(BandFile, 1, nbfBandFile, false))
	BandWindow=WindowCreateStream(BandFile, ksTypeWriteBeforeRead, wordItem, nahBandWindow)
]

and OpenForFonts(pDoc) be
[
	let PressFile = pDoc>>DocG.PressFile
	WindowClose(pDoc>>DocG.EL)
	WindowClose(pDoc>>DocG.DL)
]

and CloseDown(pDoc) be
[
	DisableComments()
	WindowClose(FontWindow)
	ResetSpruceFile(FontFile)
	WindowClose(BandWindow)
	ResetSpruceFile(BandFile)
	ResetSpruceFile(pDoc>>DocG.PressFile)
]

and PressDirectories(pDoc) be
[
	CursorChar($D)

// D O C U M E N T   DIRECTORY

	CursorDigit(0)
	let PressFile=pDoc>>DocG.PressFile
	let fileCode = PressFile>>SPruceFile.fileCode
	let EL=pDoc>>DocG.EL

	let DocDir = nil
	// Fill in creator, file name, date -- set up DocDir
	let code = FillInNames(EL, pDoc, 0, lv DocDir)
	if code then
		[
		let host = pDoc>>DocG.FileHost
		SpruceCondition(code, ECFileTerminate, fileCode, host rshift 8, host&#377)
		]
	let PressLength = vec 1
	FileLeng(PressFile, PressLength, wordItem)
	DoubleSub(PressLength, table [ 0;PressRecordSize ])
	DblShift(PressLength, LogPressRecordSize)
	if PressLength!0 then SpruceCondition(601, ECFileTerminate, fileCode)
	let nPressRecs=PressLength!1+1
	unless DocDir>>DDV.nRecs eq nPressRecs then SpruceCondition(603, ECFileTerminate, fileCode)
	let nParts=DocDir>>DDV.nParts
	unless nParts*(size PE/16) le
		DocDir>>DDV.pdRecs*PressRecordSize then
			SpruceCondition(604, ECFileTerminate, fileCode)
	
	let firstCopy=DocDir>>DDV.fCopy
	let lastCopy=DocDir>>DDV.lCopy

// P A R T  DIRECTORY

	CursorDigit()
//Find the font part and count "pages" in the document.
	SetPartBounds(EL, DocDir>>DDV.pdStart, DocDir>>DDV.pdRecs)
	SetPositioninPart(EL, DPzero)		//Start reading parts here
	WindowGetPosition(EL, lv pDoc>>DocG.partStart)	//For later reference

	let FontPart=vec size PE/16		//To hold font part goodies
	let fontfound=false
	let nPages=0
	let thisPage=0
	for i=1 to nParts do
		[
		let Part=vec size PE/16
		WindowReadBlock(EL, Part, size PE/16)
		if Part>>PE.Type eq PETypeFont then	//Font part
			[
			MoveBlock(FontPart, Part, size PE/16)
			fontfound=true
			]
		if Part>>PE.Type eq PETypePage then	//Page part (ignore other parts)
			[
			thisPage=thisPage+1
			if thisPage ge pDoc>>DocG.UserPageStart &
			   thisPage le pDoc>>DocG.UserPageEnd then
				nPages=nPages+1
			]
		]
	unless fontfound then SpruceCondition(605, ECFileTerminate, fileCode)

	if pDoc>>DocG.nCopies eq 0 then
		pDoc>>DocG.nCopies=lastCopy-firstCopy+1
	if (pDoc>>DocG.nCopies < 0) % ( pDoc>>DocG.nCopies >1000) then SpruceCondition(607, ECFileTerminate, fileCode)
	if pDoc>>DocG.duplex do
		[
		let nSheets = nPages/2
		test nSheets > 300 then [ pDoc>>DocG.duplex = false; SpruceCondition(625, ECWarning) ]
		or if nSheets*(pDoc>>DocG.nCopies) >300 do [ SpruceCondition(626, ECWarning); pDoc>>DocG.nCopies = 300/nSheets ]
		]
	if breakPage then nPages=nPages+((Capabilities&mPimFiles) eq 0? 1, (Capabilities & mBlackHousing) eq 0? 3,4 )
	pDoc>>DocG.nPages=nPages
	pDoc>>DocG.nFontLoads=0
	pDoc>>DocG.nParts=nParts

	compileif ReportSw then
		[
		Report>>REP.nPages=nPages
		Report>>REP.nCopies=lastCopy-firstCopy+1
		]

	FSPut(DocDir)		//No need for this any more

// F O N T   DIRECTORY

	CursorDigit()
	SetPartBounds(EL, FontPart>>PE.pStart, FontPart>>PE.pRecs)
	SetPositioninPart(EL, DPzero)

// Go through directory, entering fonts in the fontList (FN's)
// that are requested in the Press file.
	bestBreakFont=0
	let v=vec FElen
[fe
	let len=WindowRead(EL)
	if len ne FElen then
		[				//Cannot process these font entries
		if len eq 0 then break
		SpruceCondition(609, ECWarning)
		for i=2 to FElen do WindowRead(EL)
		loop
		]
	v!0=len
	WindowReadBlock(EL, v+1, len-1)
	let bad=false
	if v>>FE.source ne v>>FE.destm then bad=true
	if v>>FE.set gr 63 % v>>FE.fno gr 15 then bad=true
	test bad then
		[
		SpruceCondition(606, ECFileTerminate, fileCode)
		loop
		] or FEEnter(pDoc, v)
]fe repeat
	test bestBreakFont eq 0 then
		FEEnterLiteral(pDoc, "Helvetica", 12, 0, 64, 0)
		or FEEnterLiteral(pDoc, lv bestBreakFont>>FN.name,
			-bestBreakFont>>FN.siz, bestBreakFont>>FN.face, 64, 0)
	FEEnter(pDoc, LogoFont)
	// Alto Resolution Dots
	// ~~ expensive if not needed -- is there a way to wait?
	// ~~ Landscape mode only, for now -- size -32 for Portrait
	FEEnterLiteral(pDoc, "Dots", (LandscapeDevice? -256, -32), 0, 64, 2)

// F O N T  B O O K  scan
	CursorDigit()
	FontPass(pDoc)
]

//Routines for placing entries in fontList (FN's) from Press
// file font entries.

and FEEnter(pDoc, fe) be
[
	test fe>>FE.siz gr 0 then fe>>FE.siz=MulDiv(fe>>FE.siz, 635, 18) // *2540/72
		or fe>>FE.siz=-fe>>FE.siz
	unless LandscapeDevice do fe>>FE.rotn = fe>>FE.rotn + 90*60 // rotate 90

	let p=pDoc>>DocG.fontList
	let found=false
	while p ne 0 do
		[
		let dif=fe>>FE.siz-p>>FN.siz
		if dif ge -2 & dif le 2 &
		  StrEq(lv fe>>FE.fam, lv p>>FN.name) &
		  fe>>FE.rotn eq p>>FN.rotation &
		  fe>>FE.face eq p>>FN.face then
			[			//Found it!
			found=true; break
			]
		p=p>>FN.next
		]

//If we get here, it is necessary to insert a band (sic) new entry
	unless found then
		[
		p=FSGetX(size FN/16, SpruceZone, 0)
		p>>FN.next=pDoc>>DocG.fontList; pDoc>>DocG.fontList=p
		p>>FN.face=fe>>FE.face
		p>>FN.siz=fe>>FE.siz
		p>>FN.rotation=fe>>FE.rotn
		compileif size FE.fam/16 ne 10 % size FN.name/16 ne 10 then [ foo=nil ]
		MoveBlock(lv p>>FN.name, lv fe>>FE.fam, 10)
		if DefaultFontName(lv p>>FN.name) &
		  p>>FN.siz gr 350 & p>>FN.siz ls 500 &
		  (bestBreakFont eq 0 % p>>FN.siz gr bestBreakFont>>FN.siz)
			then bestBreakFont=p
		]

	let u=p>>FN.pressUses+1
	p>>FN.pressUses=u
	let use = UseEntry(p, u)
	use>>FNUse.uSet=fe>>FE.set
	use>>FNUse.uFont=fe>>FE.fno
]

// Enter a font literally from name and size.  This is necessary
// to get break-page fonts (fontset 64).

and FEEnterLiteral(pDoc, nam, siz, face, set, font) be
[
	let fe=vec size FE/16
	fe>>FE.set=set; fe>>FE.fno=font
	MoveBlock(lv fe>>FE.fam, nam, size FE.fam/16)
	fe>>FE.face=face
	fe>>FE.siz=siz
	fe>>FE.rotn=0
	FEEnter(pDoc, fe)
]

and UseEntry(fn, index) = valof
	[
	// index assumed positive
	// yields pointer to index'th set/font pair, generating new blocks if necessary
	index = index - 1
	let curUse = lv fn>>FN.useList
	for i = 0 to index rshift lnMaxPressUses do // always happens at least once
		[
		let nextUse = @curUse
		unless nextUse do
		    [
		    nextUse = FSGetX(size USeBlock/16)
		    nextUse!0 = 0
		    @curUse = nextUse
		    ]
		curUse = nextUse
		]
	resultis lv curUse>>USeBlock.fnUse^((index&maskMaxPressUses)+1)
	]

// Recognize a default font name

and DefaultFontName(n) = StrEq(n, "Helvetica")%StrEq(n, "TimesRoman")

// Compare two strings, ignoring case

and StrEq(a, b) = valof
[
	if a>>STR.length ne b>>STR.length then resultis false
	for i=1 to a>>STR.length do
		if ((a>>STR.char^i xor b>>STR.char^i) &(not #40)) ne 0 then resultis false
	resultis true
]

// F O N T  pass: scan the font directory, looking for things.

and FontPass(pDoc) be
[
//First, look up all entires in the font file
	AssignFromFontFile(pDoc)

//Now, sort fontList by ascending address in the font file
// This is intended to cut down on file thrashing.
	let changes=nil
	[
	changes=false
	let prev=(lv pDoc>>DocG.fontList)-offset FN.next
		[
		let p=prev>>FN.next
		let n=p>>FN.next
		if p eq 0 % n eq 0 then break
		let a=vec 2
		DoubleCop(a, lv n>>FN.sa)
		DoubleSub(a, lv p>>FN.sa)
		if a!0 ls 0 then
			[				//Exchange p,n
			p>>FN.next=n>>FN.next
			n>>FN.next=p
			prev>>FN.next=n
			p=n
			changes=true
			]
		if a!0 eq 0 & a!1 eq 0 then
			[				//Assigned to same font in font file: merge
			for i=1 to n>>FN.pressUses do
				[
				let c=p>>FN.pressUses+1
				p>>FN.pressUses=c
				let uP, uN = UseEntry(p, c), UseEntry(n, i)
				uP>>FNUse.uSet=uN>>FNUse.uSet
				uP>>FNUse.uFont=uN>>FNUse.uFont
				]
			p>>FN.next=n>>FN.next	//Remove from list
			let u = n>>FN.useList
			while u do [ let nextU = @u; FSPut(u); u = nextU ]
			FSPut(n)
			p=prev			//Look again
			]
		prev=p
		] repeat
	] repeatuntil changes eq false

//Assign ICC's for all fonts
	let ICCbase=0
	let p=pDoc>>DocG.fontList
	while p ne 0 do
		[
		p>>FN.ICCOffset=ICCbase
		ICCbase=ICCbase+p>>FN.ec-p>>FN.bc+1
		p=p>>FN.next
		]
	pDoc>>DocG.ICCtotal=ICCbase
]

and AssignFromFontFile(pDoc) be
[
	WindowSetPosition(FontWindow, DPzero)
	let v=vec IXLMax
	// range check for Press file date -- if not between 1974 and 1989, set to 1-1-01
	let hiDate = pDoc>>DocG.date0 rshift 1 // approx. days since 1901
	unless HI1174 le hiDate & hiDate le HI123189 do Zero(lv pDoc>>DocG.date, 2)
	hiDate = pDoc>>DocG.date0
	let familyNames = FSGetX(100, SpruceZone, 0)
	let warningIssued = false

[re
	v!0=WindowRead(FontWindow)
	WindowReadBlock(FontWindow, v+1, v>>IXH.Length-1)
	let typ=v>>IXH.Type
	switchon typ into
	 [
	 case IXTypeEnd: break
	 case IXTypeName:
		[
		let code = v>>IXN.Code
		let p=pDoc>>DocG.fontList
		while p ne 0 do
			[
			if StrEq(lv p>>FN.name, lv v>>IXN.Name) %
			   (p>>FN.match eq 0 & DefaultFontName(lv v>>IXN.Name)) then
				[
				p>>FN.match=1
				p>>FN.fam=v>>IXN.Code
				]
			p=p>>FN.next
			]
		if code > 99 endcase
		let n = FSGetX(10)
		MoveBlock(n, lv v>>IXN.Name, 10)
		familyNames!code = n
		endcase
		]
	 case IXTypeChars:
//		unless warningIssued do SpruceCondition(620, ECWarning)
//		warningIssued = true
	 case IXTypeOrbitChars:
	 case IXTypeMultiChars:
	   [
	   let p=pDoc>>DocG.fontList
	   while p ne 0 do
	      [0
	      let m=Match(v, p)
	      if m ge p>>FN.match then
		[1
		p>>FN.match=m
		p>>FN.bc=v>>IX.bc; p>>FN.ec=v>>IX.ec
		p>>FN.newFam = v>>IX.fam
		p>>FN.newFace = v>>IX.face
		p>>FN.newSize = v>>IX.siz
		p>>FN.newRot = v>>IX.rotation
		DoubleCop(lv p>>FN.sa, lv v>>IX.sa)
		DoubleCop(lv p>>FN.widthSa, lv v>>IX.sa)
		if typ eq IXTypeMultiChars then // sa, widthSa settings are more complicated
		  [2
		  DoubleCop(lv p>>FN.sa, lv v>>IXM.segs^1.sa) // rasters from first entry
		  warningIssued = false // use this as "found" flag
		// date in font file is expiration date. As of that instant the entry has expired
		  for i = v>>IXM.numSegs to 1 by -1 do
		    [3
		    let hiExpDate = v>>IXM.segs^i.date0
		    if Ugt(hiExpDate, hiDate) %
			hiExpDate eq hiDate & Ugt(v>>IXM.segs^i.date1, pDoc>>DocG.date1) then
			[4
			warningIssued = true
			DoubleCop(lv p>>FN.widthSa, lv v>>IXM.segs^i.sa)
			break
			]4
		    ]3
		  unless warningIssued do SpruceError(630) // We're in terrible shape
		  ]2
		]1
	      p=p>>FN.next
	      ]0
]re repeat
let p = pDoc>>DocG.fontList
while p do
	[
	let subst =  (p>>FN.pressUses > 1 % p>>FN.pressUses eq 1 &
	   (p>>FN.useList)>>USeBlock.fnUse^1.uSet ne 64) & p>>FN.match < 1000-2
	if subst then [ subst = FSGetX(size FN/16); MoveBlock(subst, p, size FN/16) ]
	let newFam = p>>FN.newFam
	if p>>FN.fam ne newFam then MoveBlock(lv p>>FN.name, familyNames!newFam, 10)
	p>>FN.fam = newFam; p>>FN.face = p>>FN.newFace
	p>>FN.siz = p>>FN.newSize; p>>FN.rotation = p>>FN.newRot
	if subst then [ SpruceCondition(640,ECWarning, p, subst); FSPut(subst) ]
	p = p>>FN.next
	]
for i = 0 to 99 do if familyNames!i then FSPut(familyNames!i); FSPut(familyNames)
]

// Note distance function of size*resolution -- this allows rough
// matches from all sorts of font sets!

and Match(ix, fn) = valof
[
// Compute "point size" of char in scan-lines.
// Maximum difference contribution = 100
  let rx = ix - (ix>>IXH.Type eq IXTypeMultiChars? (offset IX.resolutionx-offset IXM.resolutionx)/16, 0)
  let fontSiz=MulDiv(rx>>IX.resolutionx, ix>>IX.siz, 25400)
  let reqSiz=MulDiv(ResolutionS, fn>>FN.siz, 25400)
  let dif=(fontSiz-reqSiz)
  if dif ls 0 then dif=-dif
  if dif gr 100 then dif=100

// Rotation: contribution = 400
	if ix>>IX.rotation ne fn>>FN.rotation then dif=dif+400
// Face: contribution = 200
	if ix>>IX.face ne fn>>FN.face then dif=dif+200
// Family: contribution = 200
	if ix>>IX.fam ne fn>>FN.fam then dif=dif+200
	resultis 1000-dif
]

// DCS, July 27, 1977  10:04 PM, derived (loosely) from "Press" version
//	(only minor file open/close changes)
// August 1, 1977  10:54 PM, use file name from Press file if it exists.
// August 4, 1977  9:45 PM, adjust # BandFile buffers to nMaxMergeInputs+1
// August 26, 1977  8:17 AM, add Interpret -- main file interpretation control
// August 26, 1977  10:37 AM, remove Interpret again
// September 25, 1977  11:43 AM, handle portrait mode device in font requests
// September 30, 1977  11:42 PM, three color break page
// October 3, 1977  8:36 AM, add dots font
// October 16, 1977  2:48 PM, add "vertical dots" for landscape mode device
// October 27, 1977  4:45 PM, Pimlico!
// December 7, 1977  10:07 AM, report poor font matches in Verbose mode
// December 9, 1977  4:30 PM, don't report break font first choice not found
// December 21, 1977  4:19 PM, add OpenForFonts, better buffer management
// February 3, 1978  3:41 PM, fuzz up font match a bit
// February 15, 1978  8:46 AM, remove restriction on number of refs to single font
// May 9, 1978  10:11 AM, accommodate IXTypeOrbitChars, IXTypeMultiChars, to allow
//	accommodation of multiple fonts.widths in Press file creation
// June 9, 1978  8:48 AM, date in multi-widths entry is expiration date, not effective date
// June 14, 1978  6:32 PM, repair expiration date comparisons
// September 22, 1978  9:21 PM, report host on hopeless Press files.
// October 15, 1978  3:22 PM, modify buffering for use with fast files
// October 25, 1978  6:30 AM, tune up buffering
// October 31, 1978  8:11 AM, adjust buffering values for Band, Press files (reduce)
// November 10, 1978  2:08 PM, offer better error reporting on font substitution
// December 6, 1978  11:04 AM use Capabilities instead of printerDevice to determine number of break pages
// March 20, 1979  1:58 PM four color puffin
// August 1, 1979  3:05 PM, mBlack became mBlackHousing!!??
// August 24, 1979  1:10 PM, reasonableness check on nCopies; protect against penguin aux tray overflow
// November 16, 1979  2:23 PM, get logo font from LogoFont
// January 18, 1980  12:16 PM, use DocG.duplex
// z20598(1792)\f3