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