// K S F O R M A T  (PREPRESS)
//
// KsFormat -- translate between .AC and .KS
//
//Bcpl/f KsFormat.bcpl
//
// Given a .AC file, converts to the appropriate .KS file.  Given
// a .KS file, produces a .AC file with the same bits in the 
// characters;  the extra information in the .AC format is filled
// in by guessing from the .KS file name, or arbitrarily.

get "ix.dfs"
get "goodfoo.d"
get "KernedStrikeFormat.d"

//outgoing procedures
external
	[
	ReadKS
	MakeKS
	]

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

//incoming procedures
external
	[
	TypeChar
	TypeForm
	ReadCom
	PrePressWindowInit
	Scream
	ReadIXTempFile
	WriteIXTempFile
	FSGetX
	FSPut
	WindowSetPosition
	WindowGetPosition
	WindowReadBlock
	WindowWriteBlock
	WindowWrite
	RoundDp
	SetPosRelative
	GetPosRelative
	WindowRead
	WindowClose
	MulDiv
	GuessData
	StrCop
	]

//incoming statics
//external
//	[
//	]

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

//structure and manifest declarations

//procedures
let ReadKS(inName, outName; numargs na) be
[
let tempStr = vec 20
if na eq 0 then
	[
	ReadCom(tempStr)
	inName = tempStr
	outName = "ACtemp"
	]
let inFile = PrePressWindowInit(inName, false)
let outFile = PrePressWindowInit(outName, true)

//read the .KS file into core, and start checking it over:
let hdr=FSGetX(lStrikeHdr)
WindowReadBlock(inFile,hdr,lStrikeHdr)
if hdr>>StrikeHdr.oneBit ne 1 then Scream("Bad header in .KS input file")
if hdr>>StrikeHdr.index ne 0 then Scream("Can't handle .KSX files")
if hdr>>StrikeHdr.kerned ne 1 then Scream("Can't handle .Strike files")
let bc = hdr>>StrikeHdr.min
let ec = hdr>>StrikeHdr.max
let nc = ec-bc+1
FSPut(hdr)

let bbb=FSGetX(lBBBlock)
WindowReadBlock(inFile,bbb,lBBBlock)
let fbbox = bbb>>BBBlock.fbbox
let fbboy = bbb>>BBBlock.fbboy
let fbbdx = bbb>>BBBlock.fbbdx
let fbbdy = bbb>>BBBlock.fbbdy
FSPut(bbb)

let sb=FSGetX(lStrikeBody)
WindowReadBlock(inFile,sb,lStrikeBody)
let ascent=sb>>StrikeBody.ascent
let descent=sb>>StrikeBody.descent
let raster=sb>>StrikeBody.raster
let height=ascent+descent
FSPut(sb)

let Strike=FSGetX(raster*height)
WindowReadBlock(inFile,Strike,raster*height)
let XInSegment=FSGetX(nc+2)
WindowReadBlock(inFile,XInSegment,nc+2)
let WidthBody=FSGetX(nc+1)
WindowReadBlock(inFile,WidthBody,nc+1)
WindowClose(inFile)

//now, time to start building the output file:  first the IX parts
let fn=vec IXLName
Zero(fn,IXLName)
fn>>IXN.Type=IXTypeName
fn>>IXN.Length=IXLName
fn>>IXN.Code=1

let ix=vec IXLChars
Zero(ix, IXLChars)
ix>>IX.Type=IXTypeChars
ix>>IX.Length=IXLChars
ix>>IX.bc=bc
ix>>IX.ec=ec
ix>>IX.resolutionx=720
ix>>IX.resolutiony=720
ix>>IX.fam=1

//now, call GuessData from ReadAL to parse the file name
let famguess = vec 20
let faceguess=nil
let sizeguess=nil
GuessData(inName,lv famguess, lv faceguess, lv sizeguess)
StrCop(famguess, lv fn>>IXN.Name)
ix>>IX.face=faceguess
ix>>IX.siz=sizeguess

//All the IX data is now set up, except for .sa and .len
WriteIXTempFile(outFile,fn,ix)
//And that took care of .sa as well;  .len is left for
// later.  Outstream is left at beginning of CharacterSegment

let WT=FSGetX(nc*CharWidthsize)
let CP=FSGetX(nc*2)
let widthsFP=vec 1
WindowGetPosition(outFile,widthsFP)
let ptrsFP=vec 1
ptrsFP!0=0;  ptrsFP!1=nc*CharWidthsize
DoubleAdd(ptrsFP,widthsFP)
let rastersFP=vec 1
rastersFP!0=0; rastersFP!1=nc*2
DoubleAdd(rastersFP, ptrsFP)
WindowSetPosition(outFile,rastersFP)

//one char at a time, storing rasters into the outFile
for c=0 to nc-1 do
	[
	let thisWidth=WT+c*CharWidthsize
	let thisPtr=CP+c*2
	let spacing=WidthBody!c
	if spacing eq -1 then
		[
		//this character is non-existent
		Zero(thisWidth,CharWidthsize)
		thisWidth>>CharWidth.H=HNonExCode
		thisPtr!0=-1;  thisPtr!1=-1
		loop
		]
	TypeChar(bc+c)
	let xLeft=XInSegment!c
	let xRight=XInSegment!(c+1)
	let offsett=spacing<<WidthEntry.offsett
	let wx=spacing<<WidthEntry.width
	let WX=vec 1		//add a zero fractional part
	WX!0=wx;  WX!1=0
	if xLeft eq xRight then
		[
		//empty character
		Zero(thisWidth,CharWidthsize)
		MoveBlock(lv thisWidth>>CharWidth.WX, WX, 2)
		GetPosRelative(outFile,ptrsFP,thisPtr)
		//now, write the raster block for an empty char
		WindowWrite(outFile,0)			
		TypeForm(0)
		loop
		]

	//well, xLeft ne xRight, so there really seems to be a
	// character here.  We want to find the bits, and determine
	// the correct y-dimensions.
	let bbdx=xRight-xLeft
	let bbox=offsett+fbbox
	let maxrow=-1	//the height of the highest black bit
	let minrow=2000	//the height of the lowest black bit
	for i=0 to height-1 do
	  for j=xLeft to xRight-1 do
		[
		let oneBit=#100000	//a one at the left of the word
		let pixel, sword, sbit=nil,nil,nil
		sword=raster*i+(j rshift 4)
		sbit=j & #17
		pixel=(Strike!sword lshift sbit) & oneBit
		if pixel ne 0 then 
			[
			maxrow=Max(maxrow,i)
			minrow=Min(minrow,i)
			]
		]
	if maxrow ls minrow then 
		[
		//character was really empty after all!!
		Zero(thisWidth,CharWidthsize)
		MoveBlock(lv thisWidth>>CharWidth.WX, WX, 2)
		GetPosRelative(outFile,ptrsFP,thisPtr)
		//now, write the raster block for an empty char
		WindowWrite(outFile,0)			
		TypeForm(0)
		loop
		]
	//else, we can now compute the y dimensions of the 
	//character bounding box
	let bbdy=maxrow-minrow+1
	let bboy=ascent-maxrow-1

	//fill in the charWidth
	Zero(thisWidth,CharWidthsize)
	MoveBlock(lv thisWidth>>CharWidth.WX, WX, 2)
	thisWidth>>CharWidth.XL=bbox
	thisWidth>>CharWidth.YB=bboy
	thisWidth>>CharWidth.W=bbdx
	thisWidth>>CharWidth.H=bbdy
	GetPosRelative(outFile,ptrsFP,thisPtr)

	//now, build the rasters
	let hw=(bbdy+15)/16
	let head= nil
	let AC=FSGetX(hw*bbdx)
	Zero(AC, hw*bbdx)
	for i=0 to bbdx-1 do
	  for j=0 to bbdy-1 do
		[
		let oneBit=#100000	//a one at the left of the word
		let pixel=nil	//OK, here we pick up the crucial bit
		let srow,sword,sbit=nil,nil,nil
		srow=ascent-bboy-j-1
		sword=raster*srow+((xLeft+i) rshift 4) 
		pixel=((Strike!sword) lshift ((xLeft+i) & #17))&oneBit
		let acword=i*hw+(j rshift 4)
		AC!acword=AC!acword % (pixel rshift (j& #17))
		]
	head<<FHEAD.hw=hw
	head<<FHEAD.ns=bbdx
	WindowWrite(outFile,head)
	WindowWriteBlock(outFile,AC,hw*bbdx)
	FSPut(AC)
	TypeForm(0)
	]

FSPut(Strike)
FSPut(XInSegment)
FSPut(WidthBody)

//reset the .len field of the outFile, and cleanup
let tlen=vec 1
WindowGetPosition(outFile,tlen)
GetPosRelative(outFile,lv ix>>IX.sa, lv ix>>IX.len)
WindowSetPosition(outFile, table [ 0;0 ] )
WriteIXTempFile(outFile,fn,ix)
WindowWriteBlock(outFile,WT,nc*CharWidthsize)
FSPut(WT)
WindowWriteBlock(outFile,CP,nc*2)
FSPut(CP)
WindowClose(outFile,tlen)
TypeForm(4, tlen, "is length (words) of Chars output file.")
]


and MakeKS(inName, outName; numargs na) be
[
let inFile, outFile = nil,nil
switchon na into
	[
  case 0:
	inFile = 0;
	outFile = 0;
	[
	let switches = vec 10
	let str = vec 20
	if ReadCom(str,switches) eq 0 then break
	test switches!0 eq 0 ifso outFile = PrePressWindowInit(str, true)
	 ifnot switchon switches!1 into
		[
	  case $S:  case $s:   inFile = PrePressWindowInit(str, false)
		endcase
	  case $O:  case $o:
		outFile = PrePressWindowInit(str, true)
		endcase
	  default:
		Scream("Illegal switch on arg to MakeKS")
		] 
	] repeat
	if inFile eq 0 then inFile=PrePressWindowInit(-1,false) //ACtemp
	if outFile eq 0 then Scream("No output file for MakeKS") 
	endcase
  case 2:
	inFile = PrePressWindowInit(inName, false)
	outFile = PrePressWindowInit(outName, true)
	endcase
  default:
	Scream("Bug in MakeKS")
	]

//read header information on inFile 

let fn=vec IXLName
let ix=vec IXLMax
ReadIXTempFile(inFile, fn, ix)
if ix>>IX.Type ne IXTypeChars then Scream("Wrong input type to MakeKS")
let bc=ix>>IX.bc
let ec=ix>>IX.ec
let nc=ec-bc+1

let WT=FSGetX(nc*CharWidthsize)
WindowSetPosition(inFile, lv ix>>IX.sa)
WindowReadBlock(inFile, WT, nc*CharWidthsize)
let off=vec 1
WindowGetPosition(inFile,off)
let PT=FSGetX(nc*2)
WindowReadBlock(inFile,PT,nc*2)

//first cycle through width blocks, computing font bounding box, etc.
// fbbo(x,y) are coordinates of lower left corner of box, while
// fbbr(x,y) are coordinates of the upper right corner
let fbbox=2000
let fbboy=2000
let fbbrx=-2000
let fbbry=-2000
let maxwx=0
let minwx=2000
let strikeWidth=0

for c=0 to nc-1 do
	[
	let cW=WT+c*CharWidthsize
	if cW>>CharWidth.H eq HNonExCode then loop
	let bbox=cW>>CharWidth.XL
	let bboy=cW>>CharWidth.YB
	let bbdx=cW>>CharWidth.W
	let bbdy=cW>>CharWidth.H
	let wx=RoundDp(lv cW>>CharWidth.WX)
	if wx ls 0 then Scream("Negative Wx in input to MakeKS")
	if RoundDp(lv cW>>CharWidth.WY) ne 0 then 
		Scream("Font passed to MakeKS has non-zero Y widths")
	if bbdx eq 0 % bbdy eq 0 then
		[ //empty character:  no black bits
		maxwx=Max(maxwx, wx)
		minwx=Min(minwx, wx)
		// the character doesn't affect the font bounding box
		loop
		]
	fbbox=Min(fbbox, bbox)
	fbboy=Min(fbboy, bboy)
	fbbrx=Max(fbbrx, bbox+bbdx)
	fbbry=Max(fbbry, bboy+bbdy)
	maxwx=Max(maxwx, wx)
	minwx=Min(minwx, wx)
	strikeWidth = strikeWidth + bbdx
	]
let fbbdx=fbbrx-fbbox
let fbbdy=fbbry-fbboy

//now, for the illchar
//our illegal character will be a black slug that fills 9/16
// of the font bounding box 

let illcharbbdx=MulDiv(fbbdx,3,4)
let illcharbbdy=MulDiv(fbbdy,3,4)
let illcharbbox=fbbox+(fbbdx-illcharbbdx)/2
let illcharbboy=fbboy+(fbbdy-illcharbbdy)/2
let illcharwx=fbbdx
//fbbdx was a first guess, but now we check that the width of
// the illchar doesn't exceed maxwx, and doesn't spoil a fixed
// pitch font
if illcharwx gr maxwx then illcharwx=maxwx
if minwx eq maxwx then illcharwx=maxwx
strikeWidth=strikeWidth+illcharbbdx

let raster = (strikeWidth+15)/16
let ascent = fbbdy+fbboy
let descent = -fbboy
let height = fbbdy

let Strike=FSGetX(height*raster)
Zero(Strike, height*raster)
let XInSegment=FSGetX(nc+2)	//one for ill char, one for differencing
Zero(XInSegment, nc+2)
let WidthBody=FSGetX(nc+1)
SetBlock(WidthBody, -1, nc+1)	// -1 is code for non-existent char

let strikePos=0

//cycle through again, reading the characters and storing the rasters
for c=0 to nc-1 do
	[ //handle one char's raster
	let cW=WT+c*CharWidthsize
	if cW>>CharWidth.H eq HNonExCode then loop
	TypeChar(bc+c)
	let bbox=cW>>CharWidth.XL
	let bboy=cW>>CharWidth.YB
	let bbdx=cW>>CharWidth.W
	let bbdy=cW>>CharWidth.H
	let wx=RoundDp(lv cW>>CharWidth.WX)
	if bbdx eq 0 % bbdy eq 0 then
		[
		//an empty character, no black bits
		//There aren't any rasters, so just fill in WidthEntry
		(WidthBody+c)>>WidthEntry.offsett=0	//by convention
		if wx ls 0 then Scream("Negative Wx in input to MakeKS")
		(WidthBody+c)>>WidthEntry.width=wx
		TypeForm(0)
		loop
		]

	//read raster from inFile
	SetPosRelative(inFile,off,PT+c*2)
	let d=WindowRead(inFile)
	let hw=d<<FHEAD.hw
	let ns=d<<FHEAD.ns
	if ns ne bbdx then Scream("Input font inconsistency!")
	if hw ne (bbdy+15)/16 then Scream("Input font inconsistency!")
	let AC=FSGetX(hw*ns)
	WindowReadBlock(inFile, AC, hw*ns)

	//put raster into strike
	for i=0 to bbdx-1 do
	  for j=0 to bbdy-1 do
		[
		let oneBit=#100000	//a one at the left of the word
		let pixel=nil	//OK, here we pick up the crucial bit
		pixel=((AC!(i*hw+(j rshift 4))) lshift (j& #17))&oneBit
		let srow,sword,sbit=nil,nil,nil	//Now, where to put it?
		srow=fbbdy+fbboy-bboy-j-1
		sword=raster*srow + ((strikePos+i) rshift 4)
		sbit=(strikePos+i)& #17
		Strike!sword=Strike!sword % (pixel rshift sbit)
		]
	strikePos=strikePos+bbdx
	FSPut(AC)

	//fill in XInSegment table
	for i=c+1 to nc+1 do XInSegment!i=strikePos

	//fill in WidthEntry
	if bbox-fbbox ls 0 then Scream("Bug in MakeKS")
	(WidthBody+c)>>WidthEntry.offsett=bbox-fbbox
	if wx ls 0 then Scream("Negative Wx in input to MakeKS")
	(WidthBody+c)>>WidthEntry.width=wx
	TypeForm(0)
	] //handle one char's raster

//put ill-raster into strike
for i=0 to illcharbbdx-1 do
  for j=0 to illcharbbdy-1 do
	[
	let oneBit=#100000
	let srow,sword,sbit=nil,nil,nil	//Now, where to put it?
	srow=fbbdy+fbboy-illcharbboy-j-1
	sword=raster*srow + ((strikePos+i) rshift 4)
	sbit=(strikePos+i)& #17
	Strike!sword=Strike!sword % (oneBit rshift sbit)
	]
strikePos=strikePos+illcharbbdx
if strikePos ne strikeWidth then Scream("Bug in MakeKS: Strike")

//fill in XInSegment table
XInSegment!(nc+1)=strikePos

//fill in illchar WidthEntry
(WidthBody+nc)>>WidthEntry.offsett=illcharbbox-fbbox
(WidthBody+nc)>>WidthEntry.width=illcharwx

//we are done with the inFile, so clean up a little
WindowClose(inFile)
FSPut(WT)
FSPut(PT)

//write the KS file
let hdr=FSGetX(lStrikeHdr)
hdr>>StrikeHdr.oneBit=1
hdr>>StrikeHdr.index=0
hdr>>StrikeHdr.fixed=(maxwx eq minwx ? 1,0)
hdr>>StrikeHdr.kerned=1
hdr>>StrikeHdr.rest=0
hdr>>StrikeHdr.min=bc
hdr>>StrikeHdr.max=ec
hdr>>StrikeHdr.maxwidth=maxwx
WindowWriteBlock(outFile,hdr,lStrikeHdr)
FSPut(hdr)

let bbb=FSGetX(lBBBlock)
bbb>>BBBlock.fbbox=fbbox
bbb>>BBBlock.fbboy=fbboy
bbb>>BBBlock.fbbdx=fbbdx
bbb>>BBBlock.fbbdy=fbbdy
WindowWriteBlock(outFile,hdr,lBBBlock)
FSPut(bbb)

let sb=FSGetX(lStrikeBody)
sb>>StrikeBody.length=lStrikeBody+raster*height+(nc+2)
sb>>StrikeBody.ascent=ascent
sb>>StrikeBody.descent=descent
sb>>StrikeBody.xoffset=0
sb>>StrikeBody.raster=raster
WindowWriteBlock(outFile,sb,lStrikeBody)
FSPut(sb)

WindowWriteBlock(outFile,Strike,raster*height)
FSPut(Strike)
WindowWriteBlock(outFile,XInSegment,nc+2)
FSPut(XInSegment)

WindowWriteBlock(outFile,WidthBody,nc+1)
FSPut(WidthBody)
let tlen=vec 1
WindowGetPosition(outFile,tlen)
WindowClose(outFile,tlen)
TypeForm(4, tlen, "is length (words) of .KS output file.")
]