// font.sr	Fonts


get "ALTOFILESYS.D"
get "BRAVO1.DF"
get "CHAR.DF"
get "font.DF"
get "DISPLAY.DF"
get "VM.DF"
get "FORMAT.DF"
get "st.DF"
get "dir.DF"
// get "com.df"		these won't fit - see local decls below
// get "rn1.df"


// Incoming procedures

external	[
	errhlta
	getvp
	lockbp
	unlockbp
	gets
	stcompare
	ratio
	mult
	umax
	abs
	ugt
	inheap
	hpfree
	errhlt
	SetVab
	min
	hpalloc
	move
	RealDA
	ReadVec
// 	SetBdnFun
	]


// Incoming statics

external	[
	mpfnof
	vbp
	mpWwWwd
	vww
	vfDiablomode
	fontvis
	vffunfamissing
	vfunfamissing
	vrgcc1
	vrgcc2
// 	vfValidate
	]


// Outgoing procedures

external	[
	fillinfonth
// 	setmag
	removefont
	getfont
// 	getfontc
	establishfun
	establishofset
// 	updatefdd
	FillInFont
	CwFddl
	FddlFromFun
	LruInc
	DlruOld
	]


// Outgoing statics

external	[
	vrgcc
	vfont
	vrightadjust
// 	mpfunmagi
	vfdfirst
	mpfunfd
	fddlrutimer
	vfddfirst
	vvpargcc1
	vbprgcc1
	vbprgcc2
	vvpargcc2
	vofsetPrev
	vsgh
	vsgd
	vheighth
	vheightd
	vbld
	vblh
	vofset
// 	vmag
// 	vfdd0
// 	vupdatemag
// 	mpfunfddfaulted
// 	vfddfaulted
	vfun
	vfa
// 	vfFaultFun
	vfontFixed;
	vfddlFixed;
	vcwFontFixed;
	]


// Local statics

static	[
	vrgcc
	vfont
	vrightadjust
// 	mpfunmagi
	vfdfirst
	mpfunfd
	fddlrutimer
	vfddfirst
	vvpargcc1
	vbprgcc1
	vbprgcc2
	vvpargcc2
	vofsetPrev
	vsgh
	vsgd
	vheighth
	vheightd
	vbld
	vblh
	vofset
// 	vmag
// 	vfdd0
// 	vupdatemag
// 	mpfunfddfaulted
// 	vfddfaulted
	vfun
	vfa
// 	vfFaultFun
	vfontFixed;
	vfddlFixed;
	vcwFontFixed;
	]


// Local manifests

manifest	[
	abmsg = -3		// com.df won't fit
	mtyAnc = -2 
	cWriMax = 10
	nrlmax = 5		// rn1.df
	]


// Local structures			//rn1.df won't fit

structure RID:
	[
	nrl	bit 5
	[ ri	bit 11 ]
	= [ blank bit 4
	fun bit 4
	al bit 1
	fa bit 2 ]
	]



// S E T M A G
//
// and setmag(ww, fdefto0; numargs n) be
// [
// if n ls 2 then fdefto0 = true
// let wwd = mpWwWwd ! ww
// vmag = wwd>>WWD.mag
// let mag = wwd>>WWD.fHd ? vmag, 140
// for fun = 0 to maxfun-1 do
// 	[
// 	let fd = mpfunfd ! fun
// 	if fd eq 0 then loop
// 	let rgfdd = lv fd>>FD.rvrgfdd
// 	let dmagBest = #77777
// 	let magiBest = -1
// 	let dmagBestInCore = #77777
// 	let magiBestInCore = -1
// 	let fddFaulted = -1
// 	for magi = 0 to fd>>FD.maxmagi-1 do
// 		[
// 		let fdd = rgfdd ! magi
// 		let tmag = fdd>>FDD.mag
// 		let dmag = abs(tmag-mag)
// 		if fdd>>FDD.fddindirect then
// 			fdd = fdd>>FDD.fddindirect
// 		let fInCore = (fdd>>FDD.font ne 0) % not fdefto0
// 		if (dmag ls dmagBest) % (dmag eq dmagBest & tmag le mag) then
// 			[
// 			dmagBest = dmag
// 			magiBest = magi
// 			unless fInCore do
// 				fddFaulted = fdd
// 			]
// 		if fInCore then
// 			if (dmag ls dmagBestInCore) % (dmag eq dmagBestInCore & tmag le mag) then
// 				[
// 				dmagBestInCore = dmag
// 				magiBestInCore = magi
// 				]
// 		]
// 	mpfunmagi ! fun = magiBestInCore
// 	mpfunfddfaulted ! fun =
// 		magiBestInCore eq magiBest ? -1, fddFaulted
// 	if magiBestInCore eq -1 then
// 		[
// 		if (not fdefto0) % (fddFaulted eq -1)
// 		    % (fddFaulted>>FDD.fddindirect) then
// 			errhlta(19)
// 		]
// 	]
// ]


// R E M O V E   F O N T

let removefont(fToss0; numargs carg) = valof
[
if carg ls 1 then fToss0 = false
let dlruOldest = 0
let fddOldest = 0
let fdd = vfddfirst
while fdd ne 0 do
	[
	let tfont = fdd>> FDD.font;
// 	unless fdd>>FDD.font eq 0 % (fdd eq vfdd0 & not fToss0) do
	if (tfont ne 0) & (tfont ne vfontFixed) then
		[
		let dlru = DlruOld(fdd>>FDD.lru, fddlrutimer)
		if ugt(dlru, dlruOldest) then
			[
			dlruOldest = dlru
			fddOldest = fdd
			]
		]
	fdd = fdd>>FDD.fddnext
	]
if fddOldest ne 0 then
	[
	unless inheap(fddOldest>>FDD.font) do errhlta(20)
	hpfree(fddOldest>>FDD.font)
	fddOldest>>FDD.font = 0
// 	vupdatemag = true
	resultis true
	]
resultis false
]


// G E T F O N T
//
and getfont(fun, dld; numargs carg) = valof
[
if carg ls 2 then dld = 0
let wwd = mpWwWwd ! vww
if vfDiablomode & wwd>>WWD.fHd then
	fun = 10
fun = verifyFun(fun)
// let mag = wwd>>WWD.mag
// if mag ne vmag then
// 	setmag(vww)
// vfFaultFun = FFaultFun(fun, dld)
// if dld ne 0 then SetBdnFun(dld, fun)
let fdd = FddlFromFun(fun, wwd>>WWD.fHd)
if fdd>>FDD.font eq 0 then FillInFont(fdd)
fdd>>FDD.lru = LruInc(lv fddlrutimer)
vheightd = fdd>>FDD.height
vbld = fdd>>FDD.bl
resultis fdd>>FDD.font
]

// G E T F O N T C
//
// and getfontc(fun) = valof
// [
// fun = verifyFun(fun)
// unless mpfunfddfaulted ! fun eq -1 then
// 	[
// 	vfddfaulted = mpfunfddfaulted ! fun
// 	updatefdd(true)
// 	]
// ]

// E S T A B L I S H F U N
//
and establishfun(fun, fa, mode) = valof
[
let wwd = mpWwWwd ! vww
if vfDiablomode & (mode eq modehc % wwd>>WWD.fHd) then
	[
	fun = 10
	fa = 0
	]
fun = verifyFun(fun)
let fd = mpfunfd ! fun
let tvpargcc1, tvpargcc2 = nil, nil
if (mode eq modehc) % wwd>>WWD.fHd then
	[
	let fdh = lv fd>>FD.fdh
	let mpfargcc = lv (fdh>>FDH.rvmpfargcc)
	if mpfargcc ! fa eq 0 then
		[
		let tmpfafunfadef = lv(fdh>>FDH.rvmpfafunfadef)
// 		if (tmpfafunfadef ! fa) ne funfanil % fillinfonth(fun, fa) eq false do
		test (tmpfafunfadef ! fa) ne funfanil ifso
			[
			vfun = (tmpfafunfadef ! fa)<<FUNFA.fun
			vfa = (tmpfafunfadef ! fa)<<FUNFA.fa
			establishfun(vfun, vfa, mode)
// "Font description not available - " region #222
// by initing to fa we get the bold & italic bits for free
			let trid = fa
			trid<<RID.fun = fun
			trid<<RID.al = false		//x.ep font
			trid<<RID.nrl = nrlmax
			SetVab(abmsg,mtyAnc,222,trid)
			vffunfamissing = true
			vfunfamissing<<FUNFA.fun = fun
			vfunfamissing<<FUNFA.fa = fa
			resultis false
			]
		ifnot	errhlt("fdh");
		]
	tvpargcc1 = mpfargcc ! fa
	if mode eq modehc then tvpargcc2 = tvpargcc1
	vheighth = fdh>>FDH.height
	vblh = fdh>>FDH.bl
// moved to format
//	if vheighth ne heighth then
//		[
//		vheighth = heighth
//		vblh = fdh>>FDH.bl
//		establishofset(vsgh, vheighth, vblh)
//		]
	]
if mode ne modehc then
	[
// 	let fdd = mpfunfddfaulted ! fun
// 	let fddlIc = FddlFromFun(fun, wwd>>WWD.fSmall)
// 	if fdd eq -1 then
// 		fdd = fddlIc
	let fddl = FddlFromFun(fun, wwd>>WWD.fHd)
	if fddl>>FDD.rgcc eq 0 then
		errhlt("cc");
// 		fillinfdd(fdd)
	tvpargcc2 = fddl>>FDD.rgcc
	unless wwd>>WWD.fHd then
		tvpargcc1 = tvpargcc2
	vheightd = fddl>>FDD.height
	vbld = fddl>>FDD.bl
// moved to format
//	if vheightd ne heightd then
//		[
//		vheightd = heightd
//		vbld = fdd>>FDD.bl
//		establishofset(vsgd, vheightd, vbld)
//		]
	]
if tvpargcc1 ne vvpargcc1 then
	[
	unless vbprgcc1 eq vbprgcc2 do
		unlockbp(vbprgcc1, false)
	vrgcc1 = getvp(tvpargcc1)
	vvpargcc1 = tvpargcc1
	vbprgcc1 = vbp
	lockbp(vbprgcc1)
	]
if tvpargcc2 ne vvpargcc2 then
	[
	unless vbprgcc1 eq vbprgcc2 do
		unlockbp(vbprgcc2, false)
	vrgcc2 = getvp(tvpargcc2)
	vvpargcc2 = tvpargcc2
	vbprgcc2 = vbp
	lockbp(vbprgcc2)
	]
resultis true
]


// E S T A B L I S H O F S E T
//
and establishofset(sg, height, bl, updateSgTop, updateSgBl; numargs na) be
[
unless na eq 5 then errhlta(21)
// let top = (vofset le 0 ? height-bl+vofset+vld, height-bl+max(vofset, vld))
let newTop = height-bl+vofset
let newBl = bl-vofset
// if top gr sg>>SG.topmax then
sg>>SG.topmax = updateSgTop(sg, newTop, newBl, vofset)
// if bl gr sg>>SG.blmax then
sg>>SG.blmax = updateSgBl(sg, newTop, newBl, vofset)
vofsetPrev = min(vofset,vofsetPrev)
]

// U N F A U L T F D D
//
// and unfaultfdd(fdd) be
// [
// vupdatemag = true 
// fdd>>FDD.faulted = false
// let fdd = vfddfirst
// until fdd eq 0 do
// 	[
// 	if (fdd>>FDD.font eq 0) & (fdd>>FDD.faulted) then break
// 	fdd = fdd>>FDD.fddnext
// 	]
// vfddfaulted = fdd
// ]

// U P D A T E F D D
//
// and updatefdd(fonce) be
// [
// while vfddfaulted ne 0 do
// 	[
// 	fillinfdd(vfddfaulted)
// 	if fonce then return
// 	]
// ]

// V E R I F Y F U N
//
and verifyFun(fun) = valof
[
if (fun ge maxfun) % (mpfunfd ! fun eq fdnil) then
	[
// "No such font -" #168
// 	let trid = 0		// takes care of fa fields
// 	trid<<RID.nrl = nrlmax
// 	trid<<RID.fun = fun
// 	trid<<RID.al = false		// an al font
// 	SetVab(abmsg,mtyAnc,168,trid)
	resultis 0
	]
resultis fun
]

// F I L L I N F O N T
//
and FillInFont(fddl) be
[
if fddl>>FDD.font ne 0 then return
// if fddl>>FDD.fddindirect ne 0 then errhlta(22)
let chmod = #377
//
let lfile = fddl>>FDD.lfile
let alcdchwidth0 = fontvis+chwidth0+fontvis ! chwidth0
let cscl = alcdchwidth0>>ALCD.cscl
let sizchwidth0 = lnalcd + cscl
let siz = lfile+extrafont+sizchwidth0
let tfont = hpalloc(siz)
if tfont eq 0 then
	[
	if (vfontFixed eq 0) % (siz gr vcwFontFixed) then
		errhlt("ffx");
	if vfddlFixed ne 0 then vfddlFixed>>FDD.font = 0;
	vfddlFixed = fddl;
	tfont = vfontFixed;
	];
fddl>>FDD.font = tfont
let cfa = vec lCFA
let fptr = lv (fddl>>FDD.aFptr)
move(fptr, cfa, lFP)
cfa>>CFA.fa.da = RealDA(fptr>>FP.leaderVirtualDa)
cfa>>CFA.fa.pageNumber = 0
cfa>>CFA.fa.charPos = 0
ReadVec(cfa, lfile, fddl>>FDD.font)
// chmod considerations!!!
let pfont = fddl>>FDD.font
fddl>>FDD.height = pfont ! 0
let pf =pfont+2
let alcd = pfont+siz-lnalcd
move(alcdchwidth0-cscl, alcd-cscl, sizchwidth0)
for ch = 0 to #377 do
	[
	let talcd = pf+ch+(pf ! ch)
	if (ch eq chtab) % (ch eq chlf) % (ch eq chcr) then loop
	if talcd>>ALCD.xw eq xwnil then
		pf ! ch = alcd-(pf+ch)
	]
alcd = pfont+siz-sizchwidth0-lnalcd
pf ! chmod = alcd-(pf+chmod)
alcd ! 0 = 1
alcd ! 1 = 0
//
]


// C W   F D D L

and CwFddl(fddl) = valof
[
let lfile = fddl>>FDD.lfile
let alcdchwidth0 = fontvis + chwidth0 + fontvis ! chwidth0
let cscl = alcdchwidth0>>ALCD.cscl
let sizchwidth0 = lnalcd + cscl
resultis lfile + extrafont + sizchwidth0
]


// F   F A U L T   F U N

// and FFaultFun(fun, dld) = valof
// [
// unless mpfunfddfaulted ! fun eq -1 do
// 	[
// 	vfddfaulted = mpfunfddfaulted ! fun
// 	vfddfaulted>>FDD.faulted = true
// 	if dld ne 0 then
// 		[
// 		dld>>DLD.fFaultFun = true
// 		vfValidate = true
// 		]
// 	resultis true
// 	]
// resultis false
// ]


// F D D L   F R O M   F U N

and FddlFromFun(fun, fSmall; numargs na) = valof
[
// let magi = mpfunmagi ! fun
if na ne 2 then errhlt("na");
let fd = mpfunfd ! fun;
let fdd = fSmall ? fd>>FD.fddSmall, fd>>FD.fddLarge
// if fdd>>FDD.fddindirect then fdd = fdd>>FDD.fddindirect
// if fdd>>FDD.fddindirect then errhlt("fdd")
resultis fdd
]


// L R U   I N C

and LruInc(plrutimer) = valof
[
let lru = rv plrutimer + 1
rv plrutimer = lru
resultis lru
]


// D L R U   O L D

and DlruOld(lru, lrutimer) =
	lrutimer+1 - lru