// FontPass1.bcpl

// modified by Ramshaw,  January 19, 1982  4:18 PM 
// - added FontPickyMatch switch;  if true, means to Swat if any
//   font request can't be "perfectly" matched.
// - also adjusted font match algorithm so that off-by-one-mica
//   bugs can't make splines take over from rasters

// modified by Ramshaw,  January 18, 1981  5:26 PM 
// - adjusted font match algorithm so that chars will only take 
//   precedence over splines if they are very nearly a perfect match.

// modified by Ramshaw,  January 9, 1981  10:23 PM 
// - changed code so that icc index zero is now only used for dummies,
//   (whatever they are!).  Indices for real characters are allocated
//   starting at 1, and a dummy raster pointer is output for index 0.

// modified by Butterfield, October 13, 1980  11:18 AM
// - ResolutionB, ResolutionS, 1X instead of 10X - 10/13/80

//   errors 600
//
//Routines for preparing the two fonts for the 3100 PRESS printer.  
//
//FontsPass(wp,ws,wg,numrecs)
// is called to prepare fonts.
// wp = window on PRESS file, positioned to read Font Part.
// ws = window on scratch file, positioned at beginning.
// wg = window on GOD file (Grand Old Dictionary)
// numrecs = # records in press font part.
//NB -- resolutions need to be set by someone!!!!

get "PressParams.df"
get "PressInternals.df"
get "Ix.dfs"
get "FontPass.df"


// outgoing procedures
external
	[
	FontsPass
	]

// outgoing statics
external
	[
	ws			//Window on scratch file
	wfdir			//Window on GOD
	SetTable
	ICCtot
	]
static
	[
	ws
	wfdir
	SetTable
	ICCtot
	]

// incoming procedures
external
	[
//PRESS
	PressError
	FSGetX
	FSPut
	GetTime

//PRESSML
	MulDiv
	DoubleAdd; DoubleSub; DoubleCop

//From FONTPASS2.c
	PrintFonts
	ConvertFontParts
	ConvertFonts
	LoopFonts
	LoopFontParts
	DPADi
	SetPosRelative
	ReadIX
	ReleaseFontCore

//OS
	MoveBlock; SetBlock; Zero

//WINDOW
	WindowInit
	WindowClose
	WindowSetPosition
	WindowGetPosition
	WindowReadBlock
	WindowWriteBlock
	WindowRead
	WindowWrite
	WindowCopy

//METER
	MeterBlock
	MeterTime

//CURSOR
	CursorChar
	CursorDigit
	CursorToggle
	]

// incoming statics
external
	[
	ResolutionS
	ResolutionB
	portrait		//True if printerMode=3; else printerMode=8
	Report
	FontPickyMatch		//True => Swat on any non-perfect font match
	]

// internal statics
static
	[
	wp
	]

// File-wide structure and manifest declarations.

structure STR[
	length byte
	char^1,255 byte
	]


// Procedures

let

FontsPass(wwp,wws,wg,numrecs) be [

	compileif ReportSw then [ GetTime(lv Report>>REP.FontTime) ]
	let FPStats=vec size FPStat/16
	compileif MeterSw then [ FPStats>>FPStat.TimeIn=MeterTime() ]
	CursorChar($F)		//Fonts pass

	wp=wwp; ws=wws; wfdir=wg	//Save windows in statics.
	WindowWriteBlock(ws,0,6)		//Save spot for 3 numbers...
	let st1=vec 65
	SetTable=st1			//Main font-set table.
	Zero(st1,65)			// 0-64  (!!!!!!)

	ReadPressFontPart(numrecs)

	ReadCharacterDictionary(wfdir)
	ICCtot=AssignICCs()

	ConvertFontParts(wp)
	ConvertFonts()

	AssembleWidths()
	WriteDirectories()
	ReleaseFontCore()
	compileif MeterSw then
	   [
	   FPStats>>FPStat.TimeOut=MeterTime()
	   FPStats>>FPStat.ICCtotal=ICCtot
	   MeterBlock(METERFontPass,FPStats,size FPStat/16)
	   ]
	compileif ReportSw then [ GetTime(lv Report>>REP.FontTime) ]
]

and

//Read the PRESS font part and build an internal description of all
// font part requests (FPREQ) or "font part characters" (CREQ).

ReadPressFontPart(numrecs) be [
	let FontPartPos=vec 1		//Current font part position.
	WindowGetPosition(wp,FontPartPos)
	let AllowedLength=vec 1		//Maximum font part length.
	AllowedLength!0=0; AllowedLength!1=numrecs*256
	let BreakFont=false		//Flag when appending break font.

[					//Loop reading font parts..
	CursorToggle(0)
	let f=vec (size PRESSFE/16)	//Spot to read font entry.
	WindowSetPosition(wp,FontPartPos)
	let len=WindowRead(wp)
	let dlen=vec 1
	dlen!0=0; dlen!1=len
	DoubleAdd(FontPartPos,dlen)		//Update next place to look
	DoubleSub(AllowedLength,dlen)
	if AllowedLength!0 ls 0 then
		[			//We have overrun our bounds.
		PressError(600)		//The simplest error there is..
		len=0			//Get out...
		]

	test len eq 0 then
		[			//Last entry -- get break font
		BreakFont=true
		f=table [		//This is a dummy font...
		  64*256+0;
		  0*256+127;
		  9*256+$B;		//Family name
		  $R*256+$E;
		  $A*256+$K;
		  $F*256+$O;
		  $N*256+$T;
		  0;0;0;0;0;
		  0*256+0;		//Face=MRR
		  10;0			//10 Point, no rotation.
		  ]
		]
	or
		[			//Read; assume most common thing
		WindowReadBlock(wp,f,size PRESSFE/16)
		]

	compileif ReportSw then [ Report>>REP.FontsUsed=Report>>REP.FontsUsed+1 ]

	let a=f>>PRESSFE.famly		//Get first word of family.
	if (a rshift 8) gr 19 then
		[			//Illegal length
		PressError(601)		//Dump out an error message.
		loop			//and go on.
		]
	let Set=f>>PRESSFE.set
	if (Set gr 63) & (BreakFont eq 0) then
		[			//Illegal font set.
		PressError(602)		//Give him a message.
		loop
		]			//And go after next font entry.
	let Font=f>>PRESSFE.font
	if Font gr 15 then
		[			//Illegal font number.
		PressError(603)
		loop
		]

	let g=nil
	test a eq 0 then
		[			//FontPartCharacter
		g=FSGetX(size CREQ/16)
		Zero(g,(size CREQ/16))
		g>>CREQ.type=FontPartCharacter
		let fp=vec 1
		DoubleCop(fp,FontPartPos)
		DoubleSub(fp,dlen)
		DoubleAdd(fp,table [ 0;3 ])
		DoubleCop(lv g>>CREQ.pos,fp)
		g>>CREQ.len=len-3
		f>>PRESSFE.n=f>>PRESSFE.m
		]
	or
		[			//Standard.
		g=FSGetX(size FPREQ/16)	 //Block to remember request.
		Zero(g,(size FPREQ/16))	//Zero it!
		g>>FPREQ.type=Standard
		MoveBlock(lv g>>FPREQ.rfamly, lv f>>PRESSFE.famly, size FPREQ.rfamly/16)
		g>>FPREQ.rfacesource=f>>PRESSFE.facesource
		let s=f>>PRESSFE.siz
		g>>FPREQ.rsiz=((s ls 0)? -s,MulDiv(s,635,18))
		g>>FPREQ.rrotation=f>>PRESSFE.rotation+(portrait? 90*60,0)
		]
	g>>FPREQ.rmn=f>>PRESSFE.mn


//Now put this REQ on the correct list for this set,font
	let r=SetTable!Set
	if r eq 0 then
		[
		r=FSGetX(size SET/16)
		Zero(r,(size SET/16))
		SetTable!Set=r
		]
	let f=r>>SET.font^Font
	if f eq 0 then
		[
		f=FSGetX(size FONT/16)
		Zero(f,(size FONT/16))
		f>>FONT.bc=255
		f>>FONT.font=Font
		f>>FONT.set=Set
		r>>SET.font^Font=f
		]
// f -> "font" header for this font set.
	let m=g>>FPREQ.rm
	let n=g>>FPREQ.rn
	let p=lv f>>FONT.segments	//Header for pieces of fonts.

[	if @p eq 0 then break		//Look for correct position
	let t=@p
	if n ls t>>FPREQ.rm then break //good place for it.
	test n le t>>FPREQ.rn
	ifso	[		//We are inserting one that overlaps
				//t.  Two cases: (1) ours extends to left
				//of t, and t is pared down, or (2) ours
				//lies entirely in t, and t is split.
		if m gr t>>FPREQ.rm then
			[
			let nt=FSGetX(size FPREQ/16)
			MoveBlock(nt,t,(size FPREQ/16))
			nt>>FPREQ.rn=m-1
			@nt=@p
			@p=nt
			p=nt
			]
		t>>FPREQ.rm=n+1
		if t>>FPREQ.rm gr t>>FPREQ.rn then
			[		//Delete t entirely!
			@p=@t
			FSPut(t)
			]
		break			//Ready to put it in.
		]
	ifnot	[			//We end beyond t. But we may
					//have to pare it down.
		test m le t>>FPREQ.rm then
			[		//Delete t entirely
			@p=@t
			FSPut(t)
			] or
		test m le t>>FPREQ.rn then
			[
			t>>FPREQ.rn=m-1
			p=t		//Move right
			]
		or p=t
		]
] repeat

	@g=@p; @p=g			//Link it in.
] repeatuntil BreakFont			//Read Font part

]

and

//Read the directory file and find the best match with each font
// part request.

ReadCharacterDictionary(wfdir) be [

//Now read the directory from the mighty file, and piece it all together.
	let pFont=vec 3
	let sn=0
	let ix=vec IXLMax

[	CursorToggle(1)
	ReadIX(wfdir,ix)		//Read an entry.
	sn=sn+1
	switchon ix>>IX.Type into
	[
	case IXTypeEnd:	break		//Done.

	case IXTypeName:
		[			//Distribute the name.
		@pFont=0		//Initialize looper
		while LoopFontParts(pFont) do
			[		//See if name matches.
			let p=pFont!0
			if p>>FPREQ.type ne FontPartCharacter &
			  ComStr(lv p>>FPREQ.rfamly,lv ix>>IXN.Name) then
				[
				p>>FPREQ.named=true
				p>>FPREQ.rfam=ix>>IXN.Code
				]
			]
		]
		endcase
	case IXTypeMultiChars:	//reformat to look like OrbitChars
		[
		ix>>IX.Type=IXTypeOrbitChars
		let rx=ix>>IXM.resolutionx
		let ry=ix>>IXM.resolutiony
		MoveBlock(lv ix>>IX.sa,lv ix>>IXM.segs^1.sa,4)	//move sa,len
		ix>>IX.resolutionx=rx
		ix>>IX.resolutiony=ry
		]
		//endcase intentionally omitted
	case IXTypeChars: //error message some day???
	case IXTypeOrbitChars:
	case IXTypeSplines:
		[			//See if we are a good match.
		@pFont=0		//Initialize looper
		while LoopFontParts(pFont) do
			[
			let p=pFont!0
			if p>>FPREQ.type ne FontPartCharacter then
			[
			let score=MatchEntries(ix,p) //Compute similarity
			if score gr p>>FPREQ.score then
				[
				p>>FPREQ.score=score
				p>>FPREQ.type=ix>>IX.Type
				//Copy current best match!
				MoveBlock(lv p>>FPREQ.famface,lv ix>>IX.famface,
				   (size IX-offset IX.famface)/16)
				p>>FPREQ.sn=sn
				]
			]
			]
		]
		endcase
	default: PressError(604)
	]
] repeat				//ReadIX until IXTypeEnd

if FontPickyMatch then
	[
	@pFont=0  //initialize looper
	while LoopFontParts(pFont) do
		[
		let p=pFont!0
		if p>>FPREQ.type ne FontPartCharacter &
		  pFont!2 le 63  &   //don't worry about the BreakFont
		  p>>FPREQ.score ls 118   //a spline match counts 118
		then  PressError(605, lv p>>FPREQ.rfamly,
			p>>FPREQ.rface,
			p>>FPREQ.rsiz,
			p>>FPREQ.rrotation-(portrait ? 90*60,0))
		]
	]
]

and

//Compute a match score between an ix entry read from a dictionary file
// and a font piece request. Maximum score, a perfect match of rasters,
// is 120.  A perfect match by splines is 118, so that rasters will take
// precedence even if someone is off by a mica or two.  
//WARNING:  The constant 118 appears near the end of the prededing
//  procedure!
// Rotation=64; Size=32; Family=16; Face=8

MatchEntries(ix,p) = valof [
	let score=nil
	test (ix>>IX.Type eq IXTypeChars)%(ix>>IX.Type eq IXTypeOrbitChars) then
		[
		let fontSiz=
		  MulDiv(ix>>IX.resolutionx, ix>>IX.siz, 10*ResolutionS)
		let reqSiz = p>>FPREQ.rsiz;
		let dif=(fontSiz-reqSiz) //number of micas of difference
		if dif ls 0 then dif=-dif
		//max allowable error is about 10% more or less than request
		//spline size match is 16, so total diff allowed is 20%
		dif=MulDiv(dif, 150, reqSiz)
		if dif gr 32 then dif=32
		score=32-dif
		if ix>>IX.rotation eq p>>FPREQ.rrotation then score=score+64
		]
	or
		[
		//Lyle Ramshaw:  Splines should be used instead of
		// chars unless the chars are an excellent match.
		score=94	//Rotation OK, size match=30=32-2
		]
	if ix>>IX.face eq p>>FPREQ.rface then score=score+8
	if p>>FPREQ.named ne 0 & p>>FPREQ.rfam eq ix>>IX.fam then
		score=score+16
	resultis score
]

and

//Assign ICC addresses.
//First, update bc,ec for each font.  If there is only one FPREQ for a
// font, and if it is of type IXTypeChars, mark the FONT as verbatim
// (i.e. can just point at things for this font).
// Then, assign ICC's and put in verbatim fonts the corresponding
// disk address, or mark it as "same as some other font".

AssignICCs() =valof [
	let pFont=vec 3
	@pFont=0
	while LoopFontParts(pFont) do
		[
		let f=pFont!1
		let p=pFont!0
		let source=p>>FPREQ.rsource
		let bc=source
		let ec=source+p>>FPREQ.rn-p>>FPREQ.rm
//bc,ec in address space of available font.
		if p>>FPREQ.type ne FontPartCharacter then
			[
			if bc ls p>>FPREQ.bc then bc=p>>FPREQ.bc
			if ec gr p>>FPREQ.ec then ec=p>>FPREQ.ec
			if f>>FONT.segments eq p & p>>FPREQ.next eq 0 then
				f>>FONT.sharable=true
			]
		let off=p>>FPREQ.rm-source
		p>>FPREQ.rsource=bc	//New starting spot.
		bc=off+bc
		ec=off+ec
//bc,ec in address space of request
		if bc ls f>>FONT.bc then f>>FONT.bc=bc
		if ec gr f>>FONT.ec then f>>FONT.ec=ec
		p>>FPREQ.rm=bc
		p>>FPREQ.rn=ec
		]
	let numfonts=0
	let ICC=1	//start indices for real chars at one!
	@pFont=0
	while LoopFonts(pFont) do
		[
		let f=pFont!1		//Font pointer
		let found=false
		if f>>FONT.sharable then
			[		//See if there is another equal.
			let ppFont=vec 3
			@ppFont=0
			while LoopFonts(ppFont) do
			[
			let pf=ppFont!1
			if pf eq f then break	//None found yet
			if pf>>FONT.sharable then
			[
			let ppf=pf>>FONT.segments	//this request
			let pp=f>>FONT.segments	//later one.
			if ppf>>FPREQ.sn eq pp>>FPREQ.sn &
			  ppf>>FPREQ.rsiz eq pp>>FPREQ.rsiz &
			  ppf>>FPREQ.rrotation eq pp>>FPREQ.rrotation then
			   [
				f>>FONT.WTPos.File=FPOSDNE
				f>>FONT.AuxSet=pf>>FONT.set
				f>>FONT.AuxFont=pf>>FONT.font
				f>>FONT.indirect=true
				found=true
			   	break
			   ]
			]
			]
			]
		unless found then
			[		//Assign ICC's
			f>>FONT.ICCPos.File=FPOSDNE
			f>>FONT.ICCBase=ICC
			ICC=ICC+f>>FONT.ec-f>>FONT.bc+1
			]
		]
   resultis ICC
]

and

//Assemble widths on a font-by-font basis if needed.
	
AssembleWidths() be [
	let pFont=vec 3
	@pFont=0
	while LoopFonts(pFont) do
		[
		CursorToggle(0)
		let f=pFont!1
		let p=pFont!0
		let fp=vec 1; let file=nil
		if f>>FONT.indirect eq 0 then
		[
		test f>>FONT.sharable then
			[
			DoubleCop(fp,lv p>>FPREQ.sa)
			let rc=p>>FPREQ.rsource-p>>FPREQ.bc
			DPADi(fp,rc*CharWidthsize)
			DoubleCop(lv f>>FONT.WTPos,fp)
			file=(p>>FPREQ.type eq Converted)?
			   FPOSScratch,FPOSGod
			]
		or
			[
			let nc=f>>FONT.ec-f>>FONT.bc+1
			let CWT=FSGetX(nc*CharWidthsize)
			SetBlock(CWT,HNonExCode,nc*CharWidthsize)
			WindowGetPosition(ws,lv f>>FONT.WTPos)
			while p do
				[
				let t=p>>FPREQ.type
				test t ne FontPartCharacter then
				[
				file=((t eq IXTypeChars)%(t eq IXTypeOrbitChars))? wfdir,ws
				DoubleCop(fp,lv p>>FPREQ.sa)
				let rc=p>>FPREQ.rsource-p>>FPREQ.bc
				let nc=p>>FPREQ.rn-p>>FPREQ.rn+1
				DPADi(fp,rc*CharWidthsize)
				WindowSetPosition(file,fp)
				let oc=p>>FPREQ.rm-f>>FONT.bc
				WindowReadBlock(file,CWT+oc*CharWidthsize,
					nc*CharWidthsize)
				]
				or
				MoveBlock(CWT+CharWidthsize*(p>>FPREQ.rm-f>>FONT.bc),
					lv p>>CREQ.widths,CharWidthsize)
				p=p>>FPREQ.next
				]
			WindowSetPosition(ws,lv f>>FONT.WTPos)
			WindowWriteBlock(ws,CWT,nc*CharWidthsize)
			file=FPOSScratch
			]
		f>>FONT.WTPos.File=file
		]
		]
]

and

//Write directories!!!!!

WriteDirectories() be [
	let FSpos=vec 1
	let CDpos=vec 1
	let pFont=vec 3

//Write FS directory.
	WindowGetPosition(ws,FSpos)
	@pFont=0
	while LoopFonts(pFont) do
		[
		CursorToggle(1)
		let f=pFont!1
		WindowWriteBlock(ws,lv f>>FONT.fs,size FDES/16)
		]

//Write CD directory.
	WindowGetPosition(ws,CDpos)
	WindowWriteBlock(ws,table [ 0;0 ] ,2) //pointer for dummy index
	let cp=vec 1
	WindowGetPosition(ws,cp)	//Account current position.
	@pFont=0
	while LoopFonts(pFont) do
		[
		CursorToggle(1)
		let f=pFont!1
		if f>>FONT.indirect eq 0 then
		[
		let fp=vec 1
		let CD=vec 512
		SetBlock(CD,-1,512)
		let p=pFont!0
		while p do
			[
			let t=p>>FPREQ.type
			test t ne FontPartCharacter then
			[
			compileif ReportSw then
			 [
			 let fr=Report>>REP.FontsRecorded
			 if fr ne nReportFonts then
			  [
			  let q=(lv Report>>REP.fonts)+(size REPFont/16)*fr
			  fr=fr+1
			  Report>>REP.FontsRecorded=fr
			  q>>REPFont.fam=p>>FPREQ.rfam
			  q>>REPFont.face=p>>FPREQ.rface
			  q>>REPFont.siz=p>>FPREQ.rsiz
			  q>>REPFont.used=p>>FPREQ.fam
			  ]
			 ]
			let file=((t eq IXTypeChars)%(t eq IXTypeOrbitChars))? wfdir,ws
			let off=vec 1
			DoubleCop(off,lv p>>FPREQ.sa)
			let rc=p>>FPREQ.rsource-p>>FPREQ.bc
			let nc=p>>FPREQ.rn-p>>FPREQ.rm+1
			let nac=p>>FPREQ.ec-p>>FPREQ.bc+1
			DPADi(off,CharWidthsize*nac)	//Off=beg of CD
			DoubleCop(fp,off)
			DPADi(fp,rc*2)
			WindowSetPosition(file,fp)
			let oc=p>>FPREQ.rm-f>>FONT.bc
			WindowReadBlock(file,CD+oc*2,nc*2)
			if ((t eq IXTypeChars)%(t eq IXTypeOrbitChars)) then
			  [				//Re-locate addresses.
			  for i=0 to nc-1 do
				[
				let p=CD+(oc+i)*2
				if p!0 ne -1 then
				   [
				   DoubleAdd(p,off)
				   p>>FPOS.File=FPOSGod
				   ]
				]
			   ]
			]
			or
			[	//FontPartChar
			DoubleCop(CD+p>>FPREQ.rm*2,lv p>>CREQ.pos)
			]
			p=p>>FPREQ.next
			]
		let nc=f>>FONT.ec-f>>FONT.bc+1
		WindowSetPosition(ws,cp)
		WindowWriteBlock(ws,CD,nc*2)
		WindowGetPosition(ws,cp)
		]
		]

	WindowSetPosition(ws,table [ 0;0 ])	//Return to beginning
	WindowWriteBlock(ws,cp,2)		//Current end of file....
	WindowWriteBlock(ws,FSpos,2)		// and fill in Font Set adr
	WindowWriteBlock(ws,CDpos,2)		// and CD adr
]

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