// F I L E O P S  (PREPRESS)
// catalog number ???
//
// Extract(f)		Performs extract operation on file f.
// MergeDelete(f,mflg)	Performs merge, supercede, delete  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.

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

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

// 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
	OpenFile
	Closes

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

// internal statics
//static
//	[
//	]

// File-wide structure and manifest declarations.

structure IXD :
 [
	next	word		//List of IX entries
	file	word		//Which file it is in
	OldCode0	word		//For family name conversion
	OldCode1	word		// "
	IX	word		//...following is IX entry...
 ]

// Procedures

let

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

Extract(f) be [
	if CheckParams(gotname) eq false then IllCommand()
	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(f,false)

[	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(-f,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

//MergeDelete -- for the MERGE, SUPERCEDE or DELETE commands
//f = 1,2,3     merge or delete segments of SD,CD,WD
//mergeflag= :
// 0	Delete segment mentioned in command line.
// 1	Standard merge (any stuff in file -f merged into file f)
// 2	Supercede (same as merge, but spline widths in f supercede fixed
//		versions in -f)


MergeDelete(f,mergeflag) be [

	let w=PrePressWindowInit(f)		//Big file (file=1)
	let wx=nil
	test mergeflag then
	   [			//Look for the file to merge from
	   wx=PrePressWindowInit(-f,false) //Little file (file=0)
	   ]
	or unless CheckParams(gotname) then IllCommand()

	let d=vec IXLMax
	FillIX(d)		//Get parameters


	let ws=PrePressWindowInit(0) //Scratch file
	let foundit=false	//Did we find what the user wants (delete)?
	let famcode=0		//Max family name code seen
	let IXDList=0		//List of IX's to process
	let e=vec IXLMax

	let ffile=(mergeflag? 0,1)
	for file=ffile to 1 do
[	let wi=(file eq 0)? wx,w

[	if WindowEnd(wi) then break	//If new file is empty,...
	ReadIX(wi,e)		//Read an entry
	switchon e>>IXH.Type into
	[
case IXTypeEnd:	break	//Done
case IXTypeName: [
		let p=IXDList
		while p do
		   [
		   let pt=lv p>>IXD.IX
		   if pt>>IX.Type eq IXTypeName &
		   StrEq(lv e>>IXN.Name,lv pt>>IXN.Name) then
			break
		   p=p>>IXD.next
		   ]
		if p eq 0 then
		   [
		   p=FSGetX(size IXD/16+IXLName)
		   let pt=lv p>>IXD.IX
		   p>>IXD.next=IXDList	//Link it in
		   IXDList=p
		   MoveBlock(pt,e,IXLName)
		   p>>IXD.OldCode0=-1
		   p>>IXD.OldCode1=-1	//So will not compare
		   famcode=famcode+1
		   pt>>IXN.Code=famcode	//New code
		   if StrEq(fam,lv e>>IXN.Name) then d>>IX.fam=famcode
		   ]
		let thiscode=e>>IXN.Code	//Old fam code
		test file eq 0
		ifso p>>IXD.OldCode0=thiscode
		ifnot p>>IXD.OldCode1=thiscode
		]
		endcase
default:	[
		let copyit=true
		//Look for family & install new family code.
		let p=IXDList
		while p do
		   [
		   let pt=lv p>>IXD.IX
		   if pt>>IX.Type eq IXTypeName &
		     e>>IX.fam eq ((file eq 0)? p>>IXD.OldCode0,p>>IXD.OldCode1)
			then [ e>>IX.fam=pt>>IXN.Code; break ]
		   p=p>>IXD.next
		   ]
		if mergeflag eq 0 & file eq 1 & CompareIX(e,d) then
		   [ copyit=false; foundit=true ]
		//Look through existing ones to see if this should be omitted
		let p=IXDList
		while p do
		   [
		   let pt=lv p>>IXD.IX
		   if pt>>IX.Type eq e>>IX.Type &
		      pt>>IX.famface eq e>>IX.famface then
			[
			if CompareIX(e,pt) % (mergeflag eq 2 &
			 pt>>IX.Type eq IXTypeWidths &
			 pt>>IX.siz eq 0) then 
			   [
			   copyit=false
			   break
			   ]
			]
		   p=p>>IXD.next
		   ]
		//Put on list to do!
		if copyit then
		   [
		   p=FSGetX(size IXD/16+IXLMax)
		   p>>IXD.next=IXDList
		   p>>IXD.file=file
		   IXDList=p
		   MoveBlock(lv p>>IXD.IX,e,IXLMax)
		   ]
		]
		endcase
	]
] repeat
]					//For file

	WriteNewHeaders(ws,IXDList)	//Go write them.

//Now copy from original files to scratch.
	let p=IXDList
	while p do
	   [
	   let pt=lv p>>IXD.IX
	   if pt>>IX.Type ne IXTypeName then
		[
		let ifile=((p>>IXD.file eq 0)? wx,w)
		WindowSetPosition(ifile,lv pt>>IX.sa)
		WindowGetPosition(ws,lv pt>>IX.sa)
		WindowCopy(ifile,ws,lv pt>>IX.len)
		]
	   p=p>>IXD.next
	   ]

//Remember total length
	let tl=vec 1; WindowGetPosition(ws,tl)

//Now re-write headers
	WriteNewHeaders(ws,IXDList)

//Now copy scratch back to original
	let zero=table [ 0;0 ]
	WindowSetPosition(w,zero)
	WindowSetPosition(ws,zero)
	WindowCopy(ws,w,tl)
	WindowClose(w,-1)
	WindowClose(ws)
	if mergeflag eq 0 & foundit eq false then TypeForm("Could not find specified section to delete.*n")
]

and WriteNewHeaders(w,list) be [
	WindowSetPosition(w,table [ 0;0 ])
//Write names first
	let p=list
	while p do
	   [
	   let pt=lv p>>IXD.IX
	   if pt>>IX.Type eq IXTypeName then
		WriteIX(w,-1,pt)
	   p=p>>IXD.next
	   ]
//Write IX entries
	p=list
	while p do
	   [
	   let pt=lv p>>IXD.IX
	   if pt>>IX.Type ne IXTypeName then
		WriteIX(w,-1,pt)
	   p=p>>IXD.next
	   ]
	WriteIX(w,IXTypeEnd)	//Write the end code
]

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)
		]
	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) be [
	let strp=nil
	let sw=PrePressWindowInit(f,false,lv strp)
	let oa=vec 1; oa!0=0; oa!1=0
	outstream=OpenFile("Prepress.Lst", ksTypeWriteOnly, 1) //redirect output
	TypeForm("File: ",strp,0)

[	WindowSetPosition(sw,oa)
	let sx=vec IXLMax
	ReadIX(sw,sx)
	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:
	TypeForm("Name: ",lv sx>>IXN.Name,". Code: ",10,sx>>IXN.Code,0)
	endcase
case IXTypeSplines:
	[
	TypeForm("Splines: ")
	PrintIX(sx)
	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 IXTypeChars:
	[
	TypeForm("Characters: ")
	PrintIX(sx)
	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 IXTypeWidths:
	[
	TypeForm("Widths: ")
	PrintIX(sx)
	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)
		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

	]	//Switchon
	TypeForm(0,0,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(f) be [
	let w=PrePressWindowInit(-f,false)
	let ww=PrePressWindowInit(-3,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.
	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
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)
		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)
		FSB(5,3); FSB(6,4)
		FontMinMax(1,1,fwt)
		]
	   ]
	]

	WindowClose(w)

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