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