// S F T O S D   (PREPRESS)
// catalog number ???
//
//SFTOSD(update) makes an SDtemp file from several SF files.
//	If update=true, adds the SF files to the current SDtemp file.
//
//Splines in the SDtemp file are guaranteed monotonic in x and y!
//

get "scan.dfs"
get "scv.dfs"
get "ix.dfs"

// outgoing procedures
external
	[
	SFTOSD
	]

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

// incoming procedures
external
	[
//SCAN
	Scan
	ScanFor
	ScanUntil
	ScanInit
	ScanClose
	ScanSet
	ScanBack
	ScanGiveID
	ReadNumber
	ReadCom
	TypeForm
	StrEq
	StrCop

//WINDOW
	WindowSetPosition
	WindowGetPosition
	WindowReadBlock
	WindowWriteBlock
	WindowRead
	WindowWrite
	WindowCopy
	WindowClose

//SCV package
	SCVInit
	SCVTransformF
	SCVBeginObject
	SCVEndObject
	SCVMoveToF
	SCVDrawToF
	SCVDrawCurve
	SCVFlush

//CONVERT
	SetSCVTransform

//UTIL
	Zero; SetBlock; MoveBlock
	FSGetX
	FSPut

//FONTWIDTHS
	EncodeFace

//PREPRESS
	PrePressWindowInit
	NoFile
	Scream
	ReadIXTempFile
	WriteIXTempFile
	GetPosRelative
	TypeChar

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

// incoming statics
external
	[
	incline
	]

// internal statics
static
	[
	boundbox		//Vector for bounding box calcs.
				// Points in here:
				// 0:largest #
				// 4:smallest #
				// 8:left x
				//12:bot y
				//16:right x
				//20:top y

	sfscale			//Scale factors
	scrw			//File window
	nowordsgone		//for processseg
	]

// File-wide structure and manifest declarations.

structure CHR: [			//Structure to describe a character
	char word		// read from a file -- charcter code
	pos word 2		//File position of endoding.
	len word			//Length of encoding.
	face word		//Face code
	family word 10		//Family name (string)
	widths: @SplineWidth	//Width information for this block.
	]

manifest [
	idFAMILY=-5
	idCHARACTER=-6
	idFACE=-7
	idCOMMENT=-8
	idMADEFROM=-9
	idVERSION=-10
	idWIDTH=-11
	idFIDUCIAL=-12
	idUSE=-13
	idSPLINES=-14
	idSTOP=-15
]

// Procedures

let

//READSF command processor.

SFTOSD(update) be [
	let CD=FSGetX(256*2)		//Get table for char posn's
	SetBlock(CD,-1,256*2)		//-1 means no char there.
	let WT=FSGetX(256*SplineWidthsize) //Space for CHR structures
	for i=0 to 255 do		//Establish "non-ex" convention
		[			// by putting in unnormalized num
		let p=WT+i*SplineWidthsize
		DPCop(lv p>>SplineWidth.WX,table [ 0;-1 ])
		]
	let lens=vec 256		//Length of each encoding
	let sx=vec IXLMax		//To build index entry
	let fn=vec 20			//Spot for family name
	Zero(fn,20)
	let face=-1			//No face seen yet

	let bbl=vec 4*6			//Set up bounding box array
	boundbox=bbl
	bbl=table [ 0;3;#100000;0;	//4
		  -1;3;#100000;0 ]	//-4
	MoveBlock(boundbox,bbl,8)

	let sfsc=vec 4			//Scale factors array
	sfscale=sfsc
	FLDI(1,1); FST(1,sfscale); FST(1,sfscale+2)

	SCVInit(FSGetX,FSPut,Scream)	//Initialize scan converter

	scrw=PrePressWindowInit(0)	//Scratch File.

//If the "update" option is specified, read the current SDtemp file
// into the scratch file.  Set up CD to point to those characters,
// read in the WT information (i.e., widths), and set the "lens"
// array to contain the length of the encoding of each character.

if update then
	[
	let sw=PrePressWindowInit(-2,false)	//SDtemp
	ReadIXTempFile(sw,fn,sx)	//Read directory
	let bc=sx>>IX.bc
	let ec=sx>>IX.ec
	let nc=ec-bc+1
	WindowReadBlock(sw,WT+bc*SplineWidthsize,nc*SplineWidthsize)
	WindowReadBlock(sw,CD+bc*2,nc*2)
	let l=vec 1; l!0=0; l!1=nc*2
	for c=bc to ec do if CD!(c*2) ne -1 then
		DPSB(CD+c*2,l)		//Positions are absolute
	l!0=-1; l!1=-nc*(2+SplineWidthsize)
	DPAD(l,lv sx>>IX.len)		//Length of CE's
	WindowCopy(sw,scrw,l)		//Copy the CE's.
	WindowClose(sw)		//Close it off.
//Now need to calculate lengths of encodings of characters read
	for c=bc to ec do if CD!(c*2) ne -1 then
		[
		let p=nil		//Find next valid char.
		test c eq ec then p=l  //follows last char
		or for d=c+1 to ec do if CD!(d*2) ne -1
			then [ p=CD+d*2; break ]
		let t=vec 1
		DPCop(t,p)
		DPSB(t,CD+c*2)		//Subtract our starting posn
		lens!c=t!1		//Length!
		]
	]				//Update


	let scsf=vec SCANIlen
	let s=0

//Main loop of SFTOSD.  s is the stream for the current SF file.
// Read from it until there are no more characters (i.e. STOP is
// encountered).  Then move to the next file.

	[		 //Do until no more files in command line.
	if s eq 0 then
		[
		while s eq 0 do
			[		 //Get new file from command.
			let str=vec 20
			let sw=vec 5
			if ReadCom(str,sw) eq 0 then break //no more
			test sw!0 ne 0 then
			   [
			   ReadNumber(str)
			   switchon sw!1 into [
			case $I:	incline=FTR(1)	//Italics
				endcase
			case $X:	FST(1,sfscale)	//X scale
				endcase
			case $Y:	FST(1,sfscale+2)	//Y scale
				endcase
			default: Scream("Invalid switch")
			   ]
			   ]
			or
			   s=str		//New file
			]
		if s eq 0 then break	//No more
		unless ScanInit(scsf,s) then break	//Set up the scanner file
		ScanSet(scsf)		// and point scanner at it.
		]
	let c=Scan()			//Scan next token
	test c eq ID then
		[			//Must be STOP
		ScanClose()
		s=0
		]
	or
		[			 //Here begins a character
		if c ne LPAREN then sfscream()

		let p=vec size CHR/16
		DoAChar(p)		//Read and encode a charater.

//Character read and returned.  Fill in family and face if not
// already specified, else check for consistency.  Copy widths to the
// WT table, remember the file position of the encoding, and record
// the length of the encoding.

		let c=p>>CHR.char	//Character code
		let c2=c*2
		if CD!c2 ne -1 then	//Check if already defined
			TypeForm("Warning: character multiply defined*N")
		let f=p>>CHR.face		//Check face
		test face eq -1 % face eq f then face=f or
			TypeForm("Warning: multiple faces*n")
		f=lv p>>CHR.family	//Check family
		test fn>>IXN.Name eq 0 then StrCop(f,lv fn>>IXN.Name)
		or unless StrEq(f,lv fn>>IXN.Name) then
			TypeForm("Warning: multiple families*n")
					//Now copy widths,pos,length
		MoveBlock(WT+c*SplineWidthsize,lv p>>CHR.widths,
			SplineWidthsize)
		DPCop(CD+c2,lv p>>CHR.pos)	 //File starting posn
		lens!c=p>>CHR.len		//Length
		]
	] repeat				//Main loop.


//Calculate minimum and maximum character codes in file.
	let ec,bc=0,256
	for i=0 to 255 do if CD!(i*2) ne -1 then
		[
		if i ls bc then bc=i
		if i gr ec then ec=i
		]
	sx>>IX.ec=ec; sx>>IX.bc=bc
	let nc=(ec-bc+1)

//Now write the real file.
	let w=PrePressWindowInit(-2,true)	//SDtemp file.
//Write out a directory
	fn>>IXN.Code=0				//Family code for us.
	sx>>IX.Type=IXTypeSplines		//Fill in the IX entry.
	sx>>IX.fam=0
	sx>>IX.face=face
	sx>>IX.siz=0
	sx>>IX.rotation=0
	WriteIXTempFile(w,fn,sx)		//Write index entries.
	WindowGetPosition(w,lv sx>>IX.sa)	//Start of the coding
//Write fake WT,CD
	WindowWriteBlock(w,WT,nc*SplineWidthsize)
	let off=vec 1
	WindowGetPosition(w,off)		//CD offset
	WindowWriteBlock(w,CD,nc*2)
//Write spline codings.
	for i=bc to ec do
		[
		let i2=i*2
		if CD!i2 ne -1 then		//Character exists
		[
		WindowSetPosition(scrw,CD+i2)	//Place to read
		GetPosRelative(w,off,CD+i2)	//Where it will be
		let t=vec 1; t!0=0; t!1=lens!i	//Length
		WindowCopy(scrw,w,t)		//Copy spline
		]
		]
	GetPosRelative(w,lv sx>>IX.sa,lv sx>>IX.len) //Get total length
	let tl=vec 1; WindowGetPosition(w,tl)
//Re-write index, WT, CD.
	WindowSetPosition(w,table [ 0;0 ])	//Back to index area
	WriteIXTempFile(w,fn,sx)		//Re-write index
	WindowWriteBlock(w,WT+bc*SplineWidthsize,nc*SplineWidthsize)
	WindowWriteBlock(w,CD+bc*2,nc*2)
	WindowClose(w,tl)		//Truncate & close

	FSPut(CD); FSPut(WT)			//Return core
]

and

DoAChar(chrp) be [
	let seen=0			//Mask of props encountered
	let SplinesCount=0		//Num of (SPLINES ) props
	let character=nil
	let wv=vec 4
	for i=0 to 1 do			//Set boundbox to starting vals.
		[
		let n=i*4
		MoveBlock(boundbox+2*n+8,boundbox+n,4)
		MoveBlock(boundbox+2*n+12,boundbox+n,4)
		]

	[ //property
	let c=Scan()
	if c eq RPAREN then break	//End of character
	if c ne LPAREN then sfscream()
	c=Scan()			//Get property name
	c=idlookup(ScanGiveID())
	switchon c into [

	case idFAMILY:
		[
		c=ScanFor(ID)
		let s=ScanGiveID()	//Get pointer to string
		StrCop(s,lv chrp>>CHR.family)
		seen=seen%1
		endcase;
		]
	case idCHARACTER:		//Character code
		[
		ScanFor(NUMBER)
		character=FTR(1)
		chrp>>CHR.char=character
		TypeChar(character)	//Type message
		seen=seen%2
		endcase
		]
	case idFACE:
		[
		//Scan three things from file that are the faces.
		let n=ScanGiveID()
		ScanFor(ID)
		let f1=(n!0)&#377
		ScanFor(ID)
		let f2=(n!0)&#377
		ScanFor(ID)
		let f3=(n!0)&#377
		n=EncodeFace(f1,f2,f3)
		if n eq -1 then TypeForm("Warning: unknown faces*n")
		chrp>>CHR.face=n	//Save it
		seen=seen%4
		endcase
		]
	case idWIDTH:
		[
		ScanFor(NUMBER)
		FST(1,wv)		//Save widths in vector WV
		ScanFor(NUMBER)
		FST(1,wv+2)
		seen=seen%8
		endcase
		]
	case idFIDUCIAL:
		[			//Set scaling transformation
		let s=vec 2
		ScanFor(NUMBER)
		FST(1,s)
		ScanFor(NUMBER)
		FLDI(3,1);FDV(3,s);FML(3,sfscale)		//X scale
		FLDI(4,1);FDV(4,1);FML(4,sfscale+2)	//Y scale
		SetSCVTransform(25400,0,incline)
		seen=seen%16
		endcase
		]
	case idCOMMENT:
	case idVERSION:
	case idMADEFROM:
	case idUSE:
		endcase			//Pass up entirely
	case idSPLINES:
		[
		test SplinesCount eq 0
		ifso			//First (SPLINES ...)
		[
		if seen ne 31 then sfscream()
		SCVTransformF(wv,wv+2)	//Calculate widths
		FST(8,lv chrp>>CHR.widths.WX)
		FST(9,lv chrp>>CHR.widths.WY)
		WindowGetPosition(scrw,lv chrp>>CHR.pos) //File posn.
		]
		ifnot
		[
		WindowWrite(scrw,DSplineFontNewObject) //New SPLINES set.
		]
		SplinesCount=SplinesCount+1
		processsplines()
		endcase
		]
	default:
		sfscream()
	]
	ScanUntil(RPAREN)			//End of property
	] repeat  //property

	WindowWrite(scrw,DSplineFontEndObjects)	//End of encoding
	let ea=vec 1
	WindowGetPosition(scrw,ea)
	DPSB(ea,lv chrp>>CHR.pos)
	chrp>>CHR.len=ea!1			//Length...
	for i=0 to 3 do test ea!1 eq 1		//Calculate bounding
		then	FLDI(i,0)		// box and save away
		or	FLDV(i,boundbox+8+4*i)
	FST(0,lv chrp>>CHR.widths.XL);FST(1,lv chrp>>CHR.widths.YB)
	FST(2,lv chrp>>CHR.widths.XR);FST(3,lv chrp>>CHR.widths.YT)
	TypeForm(0)
]

and

//Process a (SPLINES ...) property.  Calls the scan-converter package
// SCVMoveToF and SCVDrawCurve to monotonize the spline
// segments that are actually read.

processsplines() be [
	let v=vec 15		//Temp for passing args to SCV
	let w=vec 1

	SCVBeginObject(false,false,processseg,true) //Make monotonic

[				//Process a closed curve
	let c=Scan()
	if c eq RPAREN then break //Done with this SPLINES
	if c ne LPAREN then sfscream()
	let firstflg=true	//Flag to put out a MOVETO
	nowordsgone=true	//and separate flag for MOVETO to segproc

[				//Process a <spline>
	c=Scan()
	if c eq RPAREN then break
	if c ne LPAREN then sfscream()
	ScanFor(NUMBER)			//Number of knots.
	let n=FTR(1)

//Scan knot list.
	ScanFor(LPAREN)
	if firstflg then		//First <spline> in <closed curve> 
		[
		ScanFor(LPAREN)
		ScanFor(NUMBER)
		FST(1,v)
		ScanFor(NUMBER)
		FST(1,w)
		SCVMoveToF(v,w)		//Call MoveTo
		ScanFor(RPAREN)
		firstflg=false
		]
	ScanUntil(RPAREN)		//Bypass remaining knots.
//Bypass weights
	c=Scan()
	if c eq LPAREN then ScanUntil(RPAREN)
//Now for derivatives
	ScanFor(LPAREN)
	for i=2 to n do			// n-1 derivatives to read
		[
		ScanFor(LPAREN)
		for j=0 to 5 do
			[		//Get a derivative
			ScanFor(NUMBER)
			if j ge 2 then
				[
				FLDI(2,((j ge 4)? 6,2))
				FDV(1,2)
				]
			FST(1,v+j*2)	//Store coefficient
			]
		SCVDrawCurve(v,v+2,v+4,v+6,v+8,v+10)
		ScanFor(RPAREN)
		]
	ScanFor(RPAREN)
//Bypass remaining stuff
	ScanUntil(RPAREN)
] repeat //process a <spline>
] repeat //process a closed curve
	ScanBack(RPAREN)		//So finishes OK
]

and

//Intercept splines being spit out of the SCV package.
// Guaranteed monotonic in x and y.
// 1. Update bounding box info
// 2. Reparameterize the spline, if necessary
// 3. Write onto the file the corresponding description.

processseg(lineflag) be [

//Update extremes of bounding box being kept
	let extreme(a1,a2,min,max) be [
		FLDV(1,min)
		if FCM(1,a1) gr 0 then FLD(1,a1)
		if FCM(1,a2) gr 0 then FLD(1,a2)
		FSTV(1,min)
		FLDV(1,max)
		if FCM(1,a1) ls 0 then FLD(1,a1)
		if FCM(1,a2) ls 0 then FLD(1,a2)
		FSTV(1,max)
		]
	extreme(csac,osac,boundbox+8,boundbox+16)
	extreme(crac,orac,boundbox+12,boundbox+20)

	let v=vec 13

//If this is the first thing to come through in the <closed curve>,
// put a MOVETO into the file.
	if nowordsgone then
		[
		nowordsgone=false
		v!0=DSplineFontMoveTo
		FST(osac,v+1)
		FST(orac,v+3)
		WindowWriteBlock(scrw,v,5)
		]

//The spline might in fact be a straight line.  If so, things can be
// made more efficient by actually putting the straight line into the
// file.  This loop sets lineflag to true if spline is really a line.
	if lineflag eq false then
		[
		lineflag=true
		for i=esb to era do if FSN(i) ne 0 then
			[ lineflag=false; break ]
		]

//If a line, put it out as a DRAWTO
	test lineflag then
		[
		v!0=DSplineFontDrawTo
		FST(csac,v+1)
		FST(crac,v+3)
		WindowWriteBlock(scrw,v,5)
		]
	or
		[
//A spline, reparameterize it so that 0 leq t leq 1.
		FLD(0,tmaxac); FSB(0,tminac)	//alpha=A
		FLD(1,0);FML(1,0)		//A*A
		FLD(2,1);FML(2,0)		//A*A*A
	for i=0 to 1 do				//s then r
		[
		FLDI(3,3);FML(3,esa+i);FML(3,tminac)
		FAD(3,esb+i)			// 3aB+b
		let iptr=i*2+v+1
		FLD(4,3);FAD(4,esb+i);FML(4,tminac);FAD(4,esc+i)
		FML(4,0);FST(4,iptr)		//new c
		FML(3,1);FST(3,iptr+4)		//new b
		FLD(3,esa+i);FML(3,2);FST(3,iptr+8) //new a
		]
		v!0=DSplineFontDrawCurve
		WindowWriteBlock(scrw,v,13)
		]
]


and

idlookup(idname) = valof [
// Look up the name in idname, and return its value.
	if StrEq(idname,"FAMILY") then resultis idFAMILY
	if StrEq(idname,"FACE") then resultis idFACE
	if StrEq(idname,"CHARACTER") then resultis idCHARACTER
	if StrEq(idname,"WIDTH") then resultis idWIDTH
	if StrEq(idname,"FIDUCIAL") then resultis idFIDUCIAL
	if StrEq(idname,"COMMENT") then resultis idCOMMENT
	if StrEq(idname,"VERSION") then resultis idVERSION
	if StrEq(idname,"MADE-FROM") then resultis idMADEFROM
	if StrEq(idname,"USE") then resultis idUSE
	if StrEq(idname,"SPLINES") then resultis idSPLINES
	if StrEq(idname,"STOP") then resultis idSTOP
	resultis ID
]

and

sfscream() be [
	Scream("Illegal SF file format")
]