// SpruceValidate.bcpl 
//  errors 790

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

external // internal
	[
	ValidateFonts
	]

external
	[
	InitSpruceFile; FontFile; FontWindow; WindowCreateStream; FSGetX; SpruceZone
	WindowRead; WindowReadBlock; MoveBlock; FileLeng; Closes; Gets
	WindowGetPosition; DoubleAdd; DoubleCop; WindowSetPosition; PutTemplate
	OrbitCharSize; SpruceError; DoubleSub; FindErrorMessage; CallSwat; SpoolFile
	DebugSystem
	]

// 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
 ]

manifest [ // Buffer strategy values for files managed here

	nbfFontFile = 16
	ncbFontFile = 5
	nbfSpoolFile = 6
	ncbSpoolFile = 4
	sizWidth = size CharWidth/16
	]

static [ vTable; familyNames; fl; lp; rasters; tIndex; rasterPos; rasterOffset; outS; fontEnd ]

// Procedures


let ValidateFonts() be
     [
     InitSpruceFile(FontFile, nbfFontFile, ncbFontFile)
     FontWindow=WindowCreateStream(FontFile, ksTypeReadOnly, wordItem, 3)
     InitSpruceFile(SpoolFile, nbfSpoolFile, ncbSpoolFile)
     outS=WindowCreateStream(SpoolFile, ksTypeWriteBeforeRead, charItem, 2)
     vTable = FSGetX(#400*(sizWidth+2))
     let ix=vec IXLMax
     familyNames = FSGetX(100, SpruceZone, 0)
	[re
	ix!0=WindowRead(FontWindow)
	WindowReadBlock(FontWindow, ix+1, ix>>IXH.Length-1)
	let typ=ix>>IXH.Type
	switchon typ into
	    [
	    case IXTypeEnd: break
	    case IXTypeName:
		[
		let code = ix>>IXN.Code
		if code > 99 endcase
		let n = FSGetX(10)
		MoveBlock(n, lv ix>>IXN.Name, 10)
		familyNames!code = n
		endcase
		]
	     case IXTypeChars:
	     case IXTypeOrbitChars:
	     case IXTypeMultiChars:
		[
		let nc = ix>>IX.ec-ix>>IX.bc+1
		let v = vec 2; fl = v; FileLeng(FontFile, fl)
		test typ eq IXTypeMultiChars then
		    [
		    let rasterSa = lv ix>>IXM.segs^1.sa
		    for i = 1 to ix>>IXM.numSegs do
			ValidateWidths(ix, lv ix>>IXM.segs^i.sa, rasterSa, nc, fl)
		    ]
	    	or ValidateWidths(ix, lv ix>>IX.sa, lv ix>>IX.sa, nc, fl)
		]
	    ]
	]re repeat
    Closes(FontWindow)
    Closes(outS)
    ]

and ValidateWidths(ix, sa, rasterSa, nc, fl) = valof
	[
	let pos = vec 2; WindowGetPosition(FontWindow, pos)
	let bc, ec = ix>>IX.bc, ix>>IX.ec
	let v = vec 2; fontEnd = v
	DoubleCop(fontEnd,sa); DoubleAdd(fontEnd,sa+2)
	if DoubleGr(fontEnd,fl) then
	    ValidateError(ix,"Bounds(font end)")
	let v = vec 2; lp = v
	lp!0 = 0
	let sizTable = nc*sizWidth; lp!1 = sizTable+nc*2
	DoubleAdd(lp,sa)
	if DoubleGe(sa,fontEnd)%DoubleGr(lp,fontEnd) resultis ValidateError(ix,"Bounds (widthtable)")
	WindowSetPosition(FontWindow, sa)
	WindowReadBlock(FontWindow, vTable, sizTable)
	let v = vec 2; rasterOffset = v
	rasterOffset!0 = 0; rasterOffset!1 = sizTable; DoubleAdd(rasterOffset, rasterSa)
	WindowSetPosition(FontWindow, rasterOffset)
	rasters = vTable+sizTable
	WindowReadBlock(FontWindow, rasters, nc*2); rasters = rasters-bc*2
	tIndex = vTable-bc*sizWidth
	let q = nil
	for i = bc to ec do q = valof
	    [
	    let charWidth = tIndex+i*sizWidth
	    let db = charWidth>>CharWidth.DB
	    let sizChar = db eq -1? -1,
		OrbitCharSize(charWidth>>CharWidth.DS, db)
	    rasterPos = rasters+i*2; let doubleM1 = rasterPos!0 eq -1 & rasterPos!1 eq -1
	    unless db eq -1 & doubleM1 % db ne -1 & not doubleM1 do
		    ValidateError(ix, "Nonex char disagreement", i, db, rasterPos)
	    if db eq -1 loop
	    DoubleAdd(rasterPos, rasterOffset)
	    if DoubleGe(rasterPos, fontEnd) resultis ValidateError(ix, "Bounds (raster start)", i)
	    if ec le #200 & i eq #40 loop // ignore space in width test
	    WindowSetPosition(FontWindow, rasterPos)
	    let mH, wM1 = Gets(FontWindow), Gets(FontWindow)
	    let sizRast = OrbitCharSize(-mH, wM1+1)
	    unless sizRast eq sizChar do
		ValidateError(ix, "Size disagreement", i, sizRast, sizChar)
	    lp!0 = 0; lp!1 = sizChar
	    DoubleAdd(lp, rasterPos); if DoubleGr(lp, fontEnd) then
		ValidateError(ix, "Bounds (raster)", i)
	    ]
	WindowSetPosition(FontWindow, pos)
	]

and ValidateError(ix, reason, arg1, arg2, arg3, arg4, arg5) be
	[
	let fn = vec 30
	MoveBlock(fn, ix, 10)
	MoveBlock(lv fn>>FN.name, familyNames!(ix>>IX.fam), 10)
	let errVec = vec 8; errVec!0 = 790; errVec!1 = fn; MoveBlock(errVec+2, lv reason, 6)
	let complaint = vec 50
	FindErrorMessage(errVec, complaint, 50, false) 
	PutTemplate(outS, "$S*N", complaint)
	if (DebugSystem&#20000) ne 0 then CallSwat(complaint)
	]
	
and DoubleGe(dbl, dbLast) = valof
	[
	if dbl!0 < 0 resultis true
	let v = vec 2; DoubleCop(v, dbl)
	DoubleSub(v, dbLast)
	unless v!0 < 0 resultis true
	resultis false
	]

and DoubleGr(dbl, dbLast) = valof
	[
	if dbl!0 < 0 resultis true
	let v = vec 2; DoubleCop(v, dbl)
	DoubleSub(v, dbLast)
	unless v!0 < 0 % v!0 eq 0 & v!1 eq 0 resultis true
	resultis false
	]

// DCS, March 14, 1979  4:39 PM, created
// March 16, 1979  9:12 AM, pound into shape
//