// P R E P R E S S U T I L
//
//Bcpl/f PrepressUtil.bcpl
//
//Last modified September 25, 1980 1:46 PM, PARC
// Changed TEX face encooding/decoding to run backwards.
//
//Modified September 12, 1980 5:51 PM by Lyle Ramshaw, PARC
// Made IXLength external.
//
//Modified April 22, 1980 9:32 AM by Lyle Ramshaw, PARC
// Changed EncodeFace and DecodeFace to allow for CMU and TEX faces.
//
//Modified February 28, 1980 10:48 AM by Kerry A. LaPrade, XEOS
// Put IllFormat call in ReadIX().
//
//Modified January 22, 1980 7:18 PM (by LaPrade)
//
//Assorted utilities for PREPRESS.
//
// FSInit(StackSize)
// Currently a hack to initialize McCreight's alloc.
// FSGet(size, [even])
// Tries to get a block of size "size". Returns pointer or zero.
// FSGetX(size, [even])
// Like FSGet, but complains if core unavailable.
// FSGetBiggest(lvSize)
// Gets biggest available block, returns it and sets @lvSize
// FSPut(ptr)
// Release block seized by FSGet or FSGetX
//
// DPCop(to,from)
// Copies double precision number
// DblShift(dp,amount)
// Shift double precision number by "amount" (>0 is to the right)
// MulDiv(a,b,c)
// Returns a*b/c (rounded)
// RoundDp(a) -- rounds double-precision integer & returns integer part
get "ix.dfs"
get "goodfoo.d" //for STRING only
// outgoing procedures
external
[
FSInit
FSGet
FSGetX
FSGetBiggest
FSPut
DPCop
DblShift
RoundDp
RoundFP
Scream
IllCommand
NoFile
IllFormat
TypeChar
EncodeFace
DecodeFace
ReadIX
WriteIX
ReadIXTempFile
WriteIXTempFile
CompareIX
PrintIX
CheckAC
IXLength
GetPosRelative
SetPosRelative
]
// outgoing statics
external
[
@prePressZone
]
static
[
@prePressZone
]
// incoming procedures
external
[
// OS
InitializeZone
Usc
// WINDOW
WindowGetPosition
WindowSetPosition
WindowRead
WindowWrite
WindowReadBlock
WindowWriteBlock
// SCAN
ReadNumber
PrintNumber
TypeForm
AppendChar
StrCop
// FLOAT
DPSB; FSTV; FLDV; FAD; FSN; FNEG; FTR; FLD; FSTDP
// PRESSML
MulDiv
]
// incoming statics
//external
// [
// ]
// internal statics
static
[
@FSTrap //Set to adr of fs cell.
]
//Free storage functions
//*********************************************************
let FSInit(StackSize) be
//*********************************************************
[
let first=@#335 //first free location
let last=(lv first)-StackSize //Leave that much room
let Size=last-first
if Usc(Size, #77777) ge 0 then Size=#77776
@#335=first+Size+1
prePressZone=InitializeZone(first, Size, SysErr, 0)
]
//*********************************************************
and FSGet(Size, even; numargs n) = valof
//*********************************************************
[
if n eq 1 then even=false
let ptr=Allocate(prePressZone, Size, -1, even)
if FSTrap ne 0 & ptr eq FSTrap then CallSwat("Free Storage trap")
resultis ptr
]
//*********************************************************
and FSGetX(Size, even; numargs n) = valof
//*********************************************************
[
if n eq 1 then even=false
let p=FSGet(Size, even)
if p eq 0 then Scream("Out of memory space. How big is your SysFont.AL?")
resultis p
]
//*********************************************************
and FSGetBiggest(lvSize) = valof
//*********************************************************
[
Allocate(prePressZone, 77777b, lvSize)
resultis Allocate(prePressZone, @lvSize)
]
//*********************************************************
and FSPut(ptr) be
//*********************************************************
[
if ptr eq FSTrap then CallSwat("Free Storage trap")
Free(prePressZone, ptr)
]
//Miscellaneous numerical functions
//*********************************************************
and DPCop(top,fromp) be
//*********************************************************
[
top!0 = fromp!0
top!1 = fromp!1
]
//*********************************************************
and DblShift(dblwordlv,amount) = valof
//*********************************************************
[
test amount ls 0 then //Left shift
[
amount=-amount
let temp=(dblwordlv!1) rshift (16-amount)
@dblwordlv=(@dblwordlv lshift amount)+temp
dblwordlv!1=(dblwordlv!1) lshift amount
]
or
[
let temp=@dblwordlv lshift (16-amount)
@dblwordlv=@dblwordlv rshift amount
dblwordlv!1=((dblwordlv!1) rshift amount)+temp
]
resultis dblwordlv!1 //low order 16 bits
]
//*********************************************************
and RoundDp(a)= valof
//*********************************************************
[
let half=vec 2;
half!0=0; half!1=#100000
DoubleAdd(half,a)
resultis half!0
]
//*********************************************************
and RoundFP(fp) = valof
//*********************************************************
[
let sv=vec 4
FSTV(10, sv)
FLD(10, fp)
let negative=(FSN(10) eq -1)
if negative then FNEG(10)
FAD(10, table [ 40100b; 0 ] ) // 0.5
let a=FTR(10)
FLDV(10, sv)
resultis (negative? -a,a)
]
//Miscellenous utilities:
//*********************************************************
and Scream(str) be
//*********************************************************
[
let strvec=vec 20
TypeForm("Scream: ",str,1,strvec)
]
//*********************************************************
and IllCommand() be
//*********************************************************
[
TypeForm("Illegal command.")
finish
]
//*********************************************************
and IllFormat() be
//*********************************************************
[
Scream("Illegal file format.")
finish
]
//*********************************************************
and NoFile(s) be TypeForm("File does not exist: ",s,0)
//*********************************************************
//*********************************************************
and TypeChar(c) be
//*********************************************************
[
let foo=c+#400 //String, length 1
TypeForm(" Character: ",lv foo," (#",8,c,$))
]
//*********************************************************
and CheckAC(p) be
[
//*********************************************************
if p>>CharWidth.W ge (1 lshift size FHEAD.ns) %
p>>CharWidth.H ge (1 lshift size FHEAD.hw)*16 then
Scream("Character too big for file format!!")
]
// EncodeFace, DecodeFace
//EncodeFace(str) => 8-bit face code.
// If str will read as a number, then interpret as size in
// logical points, and return byte form. Otherwise, take
// the first up to four characters as weight, slope, expansion,
// and character set, and enode them. Omitted characters
// are defaulted to MRRX. Error return is -1.
//DecodeFace(face, str)
// Takes 8-bit face code and stores into the specified string
// (which must have length at least 4) the descriptive
// characters, or the number of logical points.
//*********************************************************
and EncodeFace(str) = valof
//*********************************************************
[
let nonnumeric=nil
ReadNumber(str,1,lv nonnumeric)
test nonnumeric
ifnot
[
// We round the floating point logical size
// to units of half-points:
let dptemp=vec 1
FSTDP(1,dptemp); DblShift(dptemp,-1)
let logicalSize=RoundDp(dptemp)
if (logicalSize ge 0) & (logicalSize le 200) then
resultis 254-logicalSize
resultis -1
]
ifso
[
let weight,slope,expansion,charset=0,0,0,0
for i=Min(str>>STRING.length,4) by -1 to 1 do
(lv weight)!(i-1)=str>>STRING.char↑i
let w=(selecton weight into [
case 0:
case $M: case $m: 0
case $B: case $b: 2
case $L: case $l: 4
default: -100 ]) +
(selecton slope into [
case 0:
case $R: case $r: 0
case $I: case $i: 1
default: -100 ]) +
(selecton expansion into [
case 0:
case $R: case $r: 0
case $C: case $c: 6
case $E: case $e: 12
default: -100 ]) +
(selecton charset into [
case 0:
case $X: case $x: 0
case $A: case $a: 18
case $O: case $o: 36
default: -100 ])
if w ls 0 then resultis -1
resultis w
]
]
//*********************************************************
and DecodeFace(face,str) be
//*********************************************************
[
if str>>STRING.length ls 4 then
Scream("Can't decode face into string this short!")
if face eq 255 then //escape value
[
StrCop("********", str) //4 of the *'s are quotes
return
]
if (face le 254) & (face ge 54) then //TEX faces
[
let logicalSize=254-face
PrintNumber(str,logicalSize/2,10)
if (logicalSize&1) ne 0 then
[
AppendChar($., str)
AppendChar($5, str)
]
return
]
if (face le 53) & (face ge 0) then //standard faces
[
str>>STRING.char↑2=(table [ $R; $I ])!(face&1)
face=face rshift 1
str>>STRING.char↑1=(table [ $M; $B; $L ])!(face rem 3)
face=face/3
str>>STRING.char↑3=(table [ $R; $C; $E ])!(face rem 3)
face=face/3
str>>STRING.char↑4=(table [ $X; $A; $O ])!(face rem 3)
str>>STRING.length=3
if face then str>>STRING.length=4
return
]
Scream("Face value exceeds one byte!")
]
//Routines for dealing with "temporary" index files, IX entries, etc.
//*********************************************************
and ReadIX(w,v,tellTheTruth;numargs na) = valof
//*********************************************************
[ if na ls 3 then tellTheTruth=false
//Read an IX entry into vector v. Return length
let a=WindowRead(w)
let l=a<<IXH.Length
if l gr IXLMax then IllFormat()
v!0=a
WindowReadBlock(w,v+1,l-1)
if tellTheTruth%(a<<IXH.Type ne IXTypeMultiChars) then resultis l
//lie to me: replace the multi char structure with OrbitChars
let curSA,curLen=vec 1,vec 1
MoveBlock(curSA,lv v>>IXM.segs↑1.sa,2)
MoveBlock(curLen,lv v>>IXM.segs↑1.len,2)
let resx=v>>IXM.resolutionx
let resy=v>>IXM.resolutiony
v>>IX.Type=IXTypeOrbitChars
MoveBlock(lv v>>IX.sa,curSA,2)
MoveBlock(lv v>>IX.len,curLen,2)
v>>IX.resolutionx=resx
v>>IX.resolutiony=resy
]
//*********************************************************
and WriteIX(w,typ,v; numargs nargs) be
//*********************************************************
[
if typ eq -1 then typ=v>>IXH.Type
let a=nil
if nargs eq 2 then v=lv a
let len=IXLength(typ)
v>>IXH.Length=len
v>>IXH.Type=typ
WindowWriteBlock(w,v,len)
]
//*********************************************************
and ReadIXTempFile(w,f,x) be
//*********************************************************
[
ReadIX(w,f)
unless f>>IXH.Type eq IXTypeName then IllFormat()
ReadIX(w,x)
let t=x>>IXH.Type
unless t eq IXTypeSplines % t eq IXTypeChars %
t eq IXTypeWidths % t eq IXTypeOrbitChars %
t eq IXTypeTexMetrics
then IllFormat()
let u=vec 5
ReadIX(w,u)
unless u>>IXH.Type eq IXTypeEnd then IllFormat()
]
//*********************************************************
and WriteIXTempFile(w,f,x,len; numargs nargs) be
//*********************************************************
[
if nargs eq 4 then
[
let p=lv x>>IX.len
p!0=0; p!1=len
]
let p=lv x>>IX.sa
p!0=0
p!1=IXLName+IXLEnd+IXLength(x>>IXH.Type)
WriteIX(w,IXTypeName,f)
WriteIX(w,-1,x)
WriteIX(w,IXTypeEnd)
]
//*********************************************************
and IXLength(typ) =
//*********************************************************
selecton typ into [
case IXTypeName: IXLName
case IXTypeEnd: IXLEnd
case IXTypeSplines: IXLSplines
case IXTypeOrbitChars: IXLChars
case IXTypeChars: IXLChars
case IXTypeMultiChars: IXLMulti
case IXTypeWidths: IXLWidths
case IXTypeTexMetrics: IXLTexMetrics
]
//*********************************************************
and CompareIX(a,b) = valof
//*********************************************************
[ let sizDiff=a>>IX.siz-b>>IX.siz
let aresx,aresy,bresx,bresy=nil,nil,nil,nil
test a>>IX.Type eq IXTypeMultiChars then
[ aresx=a>>IXM.resolutionx;aresy=a>>IXM.resolutiony]
or [ aresx=a>>IX.resolutionx;aresy=a>>IX.resolutiony]
test b>>IX.Type eq IXTypeMultiChars then
[ bresx=b>>IXM.resolutionx;bresy=b>>IXM.resolutiony]
or [ bresx=b>>IX.resolutionx;bresy=b>>IX.resolutiony]
let charType=(a>>IX.Type eq IXTypeChars)%
(a>>IX.Type eq IXTypeOrbitChars) %
(a>>IX.Type eq IXTypeMultiChars)
resultis (a>>IX.famface eq b>>IX.famface) &
((sizDiff ge -1)&(sizDiff le 1)) &
(a>>IX.rotation eq b>>IX.rotation) &
( (not charType) % ((aresx eq bresx) & (aresy eq bresy))
)
]
//*********************************************************
and PrintIX(ix,nameList;numargs na) be
//*********************************************************
[
//Print out an ix entry
let nameStr=(na ls 2)?0,nameList!(ix>>IX.fam)
test nameStr then TypeForm(nameStr) or TypeForm("Family: ",10,ix>>IX.fam,".")
TypeForm(" Face: ")
let faceStr=vec 5; faceStr>> STRING.length=9
DecodeFace(ix>>IX.face,faceStr)
TypeForm(faceStr,". Size: ")
let pointSize=MulDiv(ix>>IX.siz,72,2540)
TypeForm(10,ix>>IX.siz," (",10,pointSize," points). Rotation: ",10,(ix>>IX.rotation)/60," degrees")
let minutes=(ix>>IX.rotation) rem 60
if minutes then TypeForm(" ",10,minutes," minutes")
TypeForm(". ",8,ix>>IX.bc,$:,8,ix>>IX.ec)
if ix>>IXH.Type eq IXTypeMultiChars then
[
TypeForm($*s,4,lv ix>>IXM.segs↑1.sa)
TypeForm($*s,4,lv ix>>IXM.segs↑1.len,0)
TypeForm(" Resolutions: ",10,ix>>IXM.resolutionx,$*s)
TypeForm(10,ix>>IXM.resolutiony, ". The number of old width blocks is: ")
let n=ix>>IXM.numSegs
TypeForm(10,n-1,".",0)
return
]
TypeForm($*s,4,lv ix>>IX.sa,$*s,4,lv ix>>IX.len,0)
if ix>>IXH.Type eq IXTypeWidths then return
if ix>>IXH.Type eq IXTypeSplines then return
if ix>>IXH.Type eq IXTypeTexMetrics then return
TypeForm(" Resolutions: ",10,ix>>IX.resolutionx,$*s)
TypeForm(10,ix>>IX.resolutiony,0)
]
//*********************************************************
and SetPosRelative(w,b,pos) be
//*********************************************************
[
let a=vec 1
DPCop(a,b)
DoubleAdd(a,pos)
WindowSetPosition(w,a)
]
//*********************************************************
and GetPosRelative(w,b,pos) be
//*********************************************************
[
WindowGetPosition(w,pos)
DPSB(pos,b)
]