// P R E P R E S S U T I L
//  scream U
//
//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"

// outgoing procedures
external
	[
	FSInit
	FSGet
	FSGetX
	FSGetBiggest
	FSPut

	MulDiv
	MulFull
	DPCop
	DblShift
	RoundDp
	RoundFP

	Scream
	IllCommand
	NoFile
	IllFormat
	TypeChar

	EncodeFace
	DecodeFace

	ReadIX
	WriteIX
	ReadIXTempFile
	WriteIXTempFile
	CompareIX
	PrintIX
	CheckCD

	GetPosRelative
	SetPosRelative
	]

// outgoing statics
external
	[
	prePressZone
	]
static
	[
	prePressZone
	]

// incoming procedures
external
	[
// OS
	InitializeZone
	Allocate
	Free
	CallSwat
	DoubleAdd
	Usc
// WINDOW
	WindowGetPosition
	WindowSetPosition
	WindowRead
	WindowWrite
	WindowReadBlock
	WindowWriteBlock
// SCAN
	TypeForm
// FLOAT
	DPSB; FSTV; FLDV; FAD; FSN; FNEG; FTR; FLD
	]

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

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("Uex")
   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)
 ]

and MulDiv(a,b,c) = valof
 [

  MulDiv=table [
	#55001	// STA 3,1,2
	#155000 // MOV 2,3  save stack pointer
	#111000 // MOV 0,2  a (b in ac 1)
	#21403	// LDA 0,3,3
	#101220	// MOVZR 0,0	c/2
	#61020  // MUL
	#31403  // LDA 2,3,3 c
	#61021  // DIV
	#101010 //  MOV# 0,0
	#121000 // MOV 1,0
	#171000 // MOV 3,2
	#35001	// LDA 3,1,2
	#1401	// JMP 1,3
	]

   resultis MulDiv(a,b,c)	//only executed first time
 ]

and MulFull(a,b,c) be
 [

  MulFull=table [
	#55001	// STA 3,1,2
	#155000 // MOV 2,3  save stack pointer
	#111000 // MOV 0,2  a (b in ac 1)
	#102400	// SUB 0,0
	#61020  // MUL
	#31403  // LDA 2,3,3 c
	#41000	// STA 0,0,2
	#45001	// STA 1,1,2
	#171000 // MOV 3,2
	#35001	// LDA 3,1,2
	#1401	// JMP 1,3
	]

   MulFull(a,b,c)	//only executed first time
 ]
//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 CheckCD(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(weight,slope,expansion) => 8-bit face code.
//	An entry that is omitted or made zero is defaulted.
//	Arguments are upper case letters (e.g. M R R)
//DecodeFace(face,lvweight,lvslope,lvexpansion)
//	Takes 8-bit face code and returns the three descriptive
//	letters.

and EncodeFace(weight,slope,expansion; numargs n) = valof
[
	for i=2 to n by -1 do (lv weight)!i=0
	let w=(selecton weight into [
		case 0:
		case $M: 0
		case $B: 2
		case $L: 4
		default: -100 ]) +
	     (selecton slope into [
		case 0:
		case $R: 0
		case $I: 1
		default: -100 ]) +
	     (selecton expansion into [
		case 0:
		case $R: 0
		case $C: 6
		case $E: 12
		default: -100 ])
	if w ls 0 then resultis -1
	resultis w
]

and DecodeFace(face,w,s,e) be
[
	@s=(table [ $R; $I ])!(face&1)
	face=face rshift 1
	@w=(table [ $M; $B; $L ])!(face rem 3)
	face=face/3
	@e=(table [ $R; $C; $E ])!(face rem 3)
]
//Routines for dealing with "temporary" index files, IX entries, etc.

and ReadIX(w,v) = valof
[
//Read an IX entry into vector v.  Return length
	let a=WindowRead(w)
	let l=a<<IXH.Length
	v!0=a
	WindowReadBlock(w,v+1,l-1)
	resultis l
]

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
		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 IXTypeChars:	IXLChars
	case IXTypeWidths:	IXLWidths
	]

and CompareIX(a,b) = 
	(a>>IX.famface eq b>>IX.famface) &
	(a>>IX.siz eq b>>IX.siz) &
	(a>>IX.rotation eq b>>IX.rotation) &
	( (a>>IX.Type ne IXTypeChars) %
	  ((a>>IX.resolutionx eq b>>IX.resolutionx) &
	   (a>>IX.resolutiony eq b>>IX.resolutiony))
	)

and PrintIX(ix) be
[
//Print out an ix entry
	TypeForm("Family: ",10,ix>>IX.fam,". Face: ")
	let weight,slope,expansion=nil,nil,nil
	DecodeFace(ix>>IX.face,lv weight,lv slope,lv expansion)
	TypeForm(weight,slope,expansion,". Size: ")
	TypeForm(10,ix>>IX.siz,". Rotation: ",10,ix>>IX.rotation)
	TypeForm(". ",8,ix>>IX.bc,$:,8,ix>>IX.ec)
	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
	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)
]