// F I L E O P S  (PREPRESS)
// BCPL/F Filops.Bcpl
//
// Extract(f)		Performs extract operation on file f.
// Rename(f)		Performs rename operation on file f.
// WidthCalc(f)		Perform width merge from file f.
// List(f)		Make a listing of a file.

//Modified December 2, 1980  9:33 PM by Lyle Ramshaw:
//  Fixed but in Width command processor.  It used to compute
//  the font bounding box information incorrectly, setting
//  FBBdx and FBBdy to the maxima of BBdx and BBdy respectively.
//  Instead, one must find the maxima of the coordinates of the
//  upper-right corner of the character bounding boxes, and let
//  that determine the font bounding box.

//Modified July 6, 1980  9:41 PM by Lyle Ramshaw:
//  Moved the patch of Oct. 26, 1979 to FillIX routine from its
//  old location in the Extract code, since the bug (GRRR!!!) 
//  showed up in the delete command, which uses FillIx.

//Modified May 8, 1980  10:56 PM by Lyle Ramshaw, PARC:
//  Added Tex Metric IXType.  Removed some of the carriage
//	returns from List.  Restored the FileName/B feature
//	for driving List and Extract from the command line.
//	Added a MultiChars case to the List command.
//	Removed the WriteNewHeaders procedure, which the
//	MergeDelete module doesn't need.

//Modified March 11, 1980  10:09 AM by Kerry LaPrade (XEOS)
//  Increased List capacity from 100 to 200 names.

//Modified January 11, 1980  1:05 PM (by LaPrade)
//  Fixed bug in List()  case: IXTypeWidths so that chars
//    greater than 277b list correctly.

//Edited by Lyle Ramshaw on Oct. 26, 1979 to patch a bug in
// the Extract command.  The "proto" IX which is built up had
// a non-initizlized "type" field.  And, if that type should just
// happen, by the luck of the stack, to be the type-code for
// MultiChars, then the CompareIX routine doesn't work, since it
// takes the resolutions from the wrong words.

get "Ix.dfs"
get "Streams.d"

// outgoing procedures
external
	[
	Extract
	Rename
	WidthCalc
	List
	FillIX
	]

// incoming procedures
external
	[
	PrePressWindowInit

//WINDOW
	WindowSetPosition
	WindowGetPosition
	WindowReadBlock
	WindowWriteBlock
	WindowRead
	WindowWrite
	WindowCopy
	WindowEnd
	WindowClose

//UTIL
	FSGetX
	FSPut
	Zero; SetBlock; MoveBlock

	ReadIX
	WriteIX
	CompareIX
	PrintIX
	ReadIXTempFile
	WriteIXTempFile
	TypeChar
	CheckParams
	Scream
	IllFormat
	IllCommand

//FONTWIDTH
	DecodeFace

//SCAN
	StrEq
	StrCop
	TypeForm

//OS
	Closes
	OpenFile
	Puts

//FLOAT
	FLD;FST;FTR;FLDI;FNEG;FAD;FSB;FML;FDV;FCM;FSN
	FLDV;FSTV;FLDDP;FSTDP;DPAD;DPSB
	DPCop
	]

// incoming statics
external
	[
	@fam
	@face
	@siz
	@rotation
	@resolutionx
	@resolutiony
	@params
	@outstream
	@bigfilename
	]

// File-wide structure and manifest declarations.

manifest
   [
   maxFontNames = 200
   ]

// Procedures

let

//Extract a font from a file f (AC or SD)

Extract(f,outName,dictName;numargs na) be
 [ if na eq 1 then
   [ if CheckParams(gotname) eq false then IllCommand()
      outName=-f	//SDtemp,ACtemp,or WDtemp
      dictName=f	//SD,CD,or WD
      if bigfilename!0 then dictName=bigfilename  //or FileName/B
   ]
	let proto=vec IXLMax
	FillIX(proto)			//Fill in from parameters read

	let famseen=false		//No code seen yet
	let fn=vec IXLName
	let d=vec IXLMax
	let w=PrePressWindowInit(dictName,false)
	if w eq 0 then
		[
		Scream("Dictionary file does not exist!")
		return
		]

[	ReadIX(w,d)			//Get an entry

	switchon d>>IXH.Type into
	[
case IXTypeEnd:
		TypeForm("No such font in the file*N")
		return
case IXTypeName:
		[
		if StrEq(fam,lv d>>IXN.Name) then
			[
			famseen=true
			proto>>IX.fam=d>>IXN.Code
			MoveBlock(fn,d,IXLName)
			]
		]
		endcase
default:	if famseen & CompareIX(d,proto) then break
	]
] repeat

	let ow=PrePressWindowInit(outName,true)
	WindowSetPosition(w,lv d>>IX.sa)	//Go get it.
	WriteIXTempFile(ow,fn,d)
	WindowCopy(w,ow,lv d>>IX.len)
	WindowClose(w)
	WindowClose(ow,-1)
]

and

//Rename -- install new features in a "temp" file.

Rename(f) be [
	let wf=PrePressWindowInit(f,true)	//Get the file, RW
	let fn=vec IXLName		//Place for name
	let ix=vec IXLMax			//and thing.
	ReadIXTempFile(wf,fn,ix)
	if (params&gotname) ne 0 then 
		[
		Zero(fn,IXLName)
		StrCop(fam,lv fn>>IXN.Name)
		ix>>IX.fam=0
		]
	if (params&gotface) ne 0 then ix>>IX.face=face
	if (params&gotsize) ne 0 then ix>>IX.siz=siz
	if (params&gotrotation) ne 0 then ix>>IX.rotation=rotation
	if (params&gotresolution) ne 0 then
		[
		ix>>IX.resolutionx=resolutionx
		ix>>IX.resolutiony=resolutiony
		]
	WindowSetPosition(wf,table [ 0;0 ])
	WriteIXTempFile(wf,fn,ix)
	WindowClose(wf,0)
]

and

//LIST command processor. File f is listed.

List(f, fullList, dictName;numargs na) be
 [ if na eq 2 then
	[
	dictName=f  //SD,CD, or WD
	if bigfilename!0 then dictName=bigfilename  //or FileName/B
	]
   let strp=nil
   let sw=PrePressWindowInit(dictName,false,lv strp)
   if sw eq 0 then 
	 [ Scream("Dictionary file does not exist");return]
	let oa=vec 1; oa!0=0; oa!1=0
	outstream=OpenFile("Prepress.Lst", ksTypeWriteOnly, 1) //redirect output
	TypeForm("File: ",strp,0)

//   let nameList=vec 100
//   Zero(nameList,100)

   let nameList = vec (maxFontNames - 1)
   Zero(nameList, maxFontNames)

[	WindowSetPosition(sw,oa)
	let sx=vec IXLMax
	ReadIX(sw,sx,true)	//If its MultiChars, so be it!!
	WindowGetPosition(sw,oa)	//So we may get back.
	let bc=sx>>IX.bc
	let ec=sx>>IX.ec
	let nc=ec-bc+1

	switchon sx>>IXH.Type into
	[
case IXTypeEnd:	break
case IXTypeName:
   [ if sx>>IXN.Code gr maxFontNames then [ Scream("Name overflow in List");endcase]
	 let nWords=(sx>>IXN.Name rshift 9)+1
    let thisName=FSGetX(nWords)
    MoveBlock(thisName,lv sx>>IXN.Name,nWords)
    nameList!(sx>>IXN.Code)=thisName
    TypeForm("Name: ",lv sx>>IXN.Name,". Code: ",10,sx>>IXN.Code,0)
  ]
	endcase
case IXTypeSplines:
	[
	TypeForm("Splines: ")
	PrintIX(sx,nameList)
	if fullList then
	[
	WindowSetPosition(sw,lv sx>>IX.sa)
	for c=bc to ec do
	   [
		let p=vec SplineWidthsize
		WindowReadBlock(sw,p,SplineWidthsize)
		let pw=lv p>>SplineWidth.WX
		unless pw!0 eq 0 & pw!1 eq -1 then
		[			//Char exists.
		TypeChar(c)
		let q=pw
		for i=0 to 5 do
		   [
		   TypeForm(2,q,$*s); q=q+2
		   ]
		TypeForm(0)
		if (params&gotsize) ne 0 then
		  [
		  FLDI(1, siz); FLDI(2, resolutionx); FLDI(3, 25400)
		  FML(1,2); FDV(1,3)
		  TypeForm("      ")
		  let q=pw
		  for i=0 to 5 do
			[
			FLD(2, q); FML(2, 1)
			TypeForm(2,2,$*s); q=q+2
			]
		  TypeForm(0)
		  ]
		]
	   ]
	]
	]
	endcase
case IXTypeOrbitChars: TypeForm("ORbit Format ")
case IXTypeChars:
	[
	TypeForm("Characters: ")
	PrintIX(sx,nameList)
	if fullList then
	[
	WindowSetPosition(sw,lv sx>>IX.sa)
	for c=bc to ec do
	   [
		let p=vec CharWidthsize
		WindowReadBlock(sw,p,CharWidthsize)
		unless p>>CharWidth.H eq HNonExCode then
		[			//Char exists
		TypeChar(c)
		TypeForm(3,lv p>>CharWidth.WX,#40,3,lv p>>CharWidth.WY,$*s)
		TypeForm(10,p>>CharWidth.XL,$*s,10,p>>CharWidth.YB,$*s)
		TypeForm(10,p>>CharWidth.W,$*s,10,p>>CharWidth.H,0)
		]
	   ]
	]
	]
	endcase
case IXTypeMultiChars:
	[
	TypeForm("MultiWidth ORbit Char's: ")
	PrintIX(sx,nameList)
	if fullList then
	[
	WindowSetPosition(sw,lv sx>>IXM.segs↑1.sa)
	for c=bc to ec do
	   [
		let p=vec CharWidthsize
		WindowReadBlock(sw,p,CharWidthsize)
		unless p>>CharWidth.H eq HNonExCode then
		[			//Char exists
		TypeChar(c)
		TypeForm(3,lv p>>CharWidth.WX,#40,3,lv p>>CharWidth.WY,$*s)
		TypeForm(10,p>>CharWidth.XL,$*s,10,p>>CharWidth.YB,$*s)
		TypeForm(10,p>>CharWidth.W,$*s,10,p>>CharWidth.H,0)
		]
	   ]
	]
	]
	endcase
case IXTypeWidths:
	[
	TypeForm("Widths: ")
	PrintIX(sx,nameList)
	if fullList then
	[
	WindowSetPosition(sw,lv sx>>IX.sa)
	let s=vec size WTB/16
	WindowReadBlock(sw,s,(size WTB/16))
	TypeForm("  Box: ")
	for i=0 to 3 do TypeForm(10,s!i,#40)
	for what=0 to 1 do
	[
	TypeForm((what? "*NY:  ","*NX:  "))
	test ((what)? s>>WTB.YWidthFixed, s>>WTB.XWidthFixed)
	   then TypeForm(10,WindowRead(sw),0)
	   or  [  for c=bc to ec do
		[
//		if c gr #37 then TypeForm(c)
		if c gr #37 then Puts(outstream, c)
		TypeForm("(#",8,c,") ")
		let wid=WindowRead(sw)
		test wid eq #100000
		ifso TypeForm("xxx;  ")
		ifnot TypeForm(10,wid,";  ")
		if (c&3) eq 3 then TypeForm(0)
		]
		TypeForm(0)
	       ]
	]
	]
	]
	endcase
case IXTypeTexMetrics:
	TypeForm("TEX Metrics: ")
	PrintIX(sx,nameList)
	endcase

	]	//Switchon
	TypeForm(0)
] repeat
	Closes(outstream)
	outstream=0		//No more redirection
	WindowClose(sw)
]

and

//WIDTH command processor.  Build a file WDtemp that contains width
// information. Width information is extracted from file f.

WidthCalc(inputName,outputName;numargs na) be
 [ if na eq 1 then
    [ inputName=-inputName
      outputName=-3
    ]
	let w=PrePressWindowInit(inputName,false)
	let ww=PrePressWindowInit(outputName,true)

	let fn=vec IXLName
	let e=vec IXLMax
	ReadIXTempFile(w,fn,e)
	WindowSetPosition(w,lv e>>IX.sa)
	let t=e>>IXH.Type
	let bc=e>>IX.bc
	let ec=e>>IX.ec
	let nc=ec-bc+1

	let fwt=vec size WTB/16		//For font width block.
	//We will store the coordinates of the upper right corner of
	//the bounding box instead of the bounding box width and height,
	//so that we can compute the font bounding box correctly.
	MoveBlock(fwt,table [ 16000;16000;-16000;-16000 ],4)

	let wx=vec 256*3; SetBlock(wx,#100000,256*3) //All non-existent
	let wy=wx+256
	let absent=wy+256

test (t eq IXTypeChars)%(t eq IXTypeOrbitChars)	
ifso	[
	FLDI(1,25400);FLDI(2,e>>IX.resolutionx);FDV(1,2)
	FLDI(2,25400);FLDI(3,e>>IX.resolutiony);FDV(2,3)

	for c=bc to ec do
	   [
		let p=vec CharWidthsize
		WindowReadBlock(w,p,CharWidthsize)
		unless p>>CharWidth.H eq HNonExCode then
		[
		absent!c=false
		let c2=c*2
		FLDDP(3,lv p>>CharWidth.WX);FML(3,1); wx!c=FTRound(3)
		FLDDP(3,lv p>>CharWidth.WY);FML(3,2); wy!c=FTRound(3)
		FLDI(3,p>>CharWidth.XL);FLDI(4,p>>CharWidth.YB)
		FLDI(5,p>>CharWidth.W);FLDI(6,p>>CharWidth.H)
		FAD(5,3); FAD(6,4)	//convert to upper right corner coords
		FontMinMax(1,2,fwt)
		]
	   ]
	]
ifnot	[
	FLDI(1,1000)

	for c=bc to ec do
	   [
		let p=vec SplineWidthsize
		WindowReadBlock(w,p,SplineWidthsize)
		let pw=lv p>>SplineWidth.WX
		unless pw!0 eq 0 & pw!1 eq -1 then
		[
		absent!c=false
		FLD(2,lv p>>SplineWidth.WX);FML(2,1); wx!c=FTRound(2)
		FLD(2,lv p>>SplineWidth.WY);FML(2,1); wy!c=FTRound(2)
		FLD(3,lv p>>SplineWidth.XL); FLD(4,lv p>>SplineWidth.YB)
		FLD(5,lv p>>SplineWidth.XR); FLD(6,lv p>>SplineWidth.YT)
		FontMinMax(1,1,fwt)
		]
	   ]
	]

	WindowClose(w)
//Reset the last two entries of the fwt to be width and height, instead
//of coords of the upper right corner.
	fwt!2=fwt!2-fwt!0
	fwt!3=fwt!3-fwt!1

//Now decide if either x or y widths are the same
	let xwv,ywv=wx!bc,wy!bc
	let xsame,ysame=true,true

	for c=bc to ec do unless absent!c then
		[
		if wx!c ne xwv then xsame=false
		if wy!c ne ywv then ysame=false
		]
	fwt>>WTB.XWidthFixed=xsame
	fwt>>WTB.YWidthFixed=ysame

//Now write the file
	e>>IXH.Type=IXTypeWidths
	WriteIXTempFile(ww,fn,e,
	   (size WTB/16)+((xsame)? 1,nc)+((ysame)? 1,nc))
	WindowWriteBlock(ww,fwt,(size WTB/16))
	test xsame then WindowWrite(ww,xwv) or
		WindowWriteBlock(ww,wx+bc,nc)
	test ysame then WindowWrite(ww,ywv) or
		WindowWriteBlock(ww,wy+bc,nc)
	WindowClose(ww,-1)
]

and

FontMinMax(sx,sy,minmax) be [
	for i=0 to 3 do
	   [
		let ac=3+i
		FML(ac,(((i&1) eq 0)? sx,sy))
		let v=FTR(ac)
		test i le 1 then
		[ if v ls minmax!i then minmax!i=v ]
		or
		[ if v gr minmax!i then minmax!i=v ]
	   ]
]

and

FillIX(s) be [
	//the Type doesn't really matter, as long as it isn't
	//IXTypeMultiChars, since this will make CompareIx screw up.
	//But we have to say something...
	s>>IX.Type=IXTypeChars
	s>>IX.Length=IXLChars

	//fill in the other stuff from global variables
	s>>IX.face=face
	s>>IX.siz=siz
	s>>IX.rotation=rotation
	s>>IX.resolutionx=resolutionx
	s>>IX.resolutiony=resolutiony
]

and FTRound(ac) = valof [
	FLDDP(31, table [ 0; #100000 ] ) //.5
	FAD(31, ac)
	resultis FTR(31)
]