// O R B I T F O R M A T  (PREPRESS)
// catalog number ???
//
// Transfers a font between types Chars and OrbitChars, and types out
// amount of space used.

//Modified by Lyle Ramshaw (PARC), January 16, 1980, to change the handling
// of empty characters.  If a character in the input font has a bounding box
// with either height or width equal to zero, that character is interpreted
// as being "empty", that is, having no associated black bits.  In the output,
// empty characters will have all dimensions of the bounding box equal to
// zero, and they will have an associated empty raster block of the appropriate
// type.
 
get "ix.dfs"

// outgoing procedures
external
	[
	OrbitFormat
	DeOrbitFormat
	]

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

// incoming procedures
external
	[
//WINDOW
	WindowRead
	WindowReadBlock
	WindowWrite
	WindowWriteBlock

//MAPACTEMP
	MapACtemp

//PREPRESSUTIL
	FSGetX
	FSPut
	Scream
	TypeForm

//OS
	Noop
	DoubleAdd
	Zero
	SetBlock
	MoveBlock
	]

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

// internal statics
static
	[
	@pack=true
	]

// File-wide structure and manifest declarations.

let DeOrbitFormat(inputName,outputName;numargs na) be
[
	if na eq 0 then
	 [ inputName="ACtemp";outputName="ACtemp"
	 ]
	let v=vec 1
	v!0=0
	MapACtemp(CheckDeOrbitIX, DeOrbitOne, v, inputName, outputName)
	TypeForm(10, v!0, " words of font storage.")
]

and OrbitFormat(inputName,outputName;numargs na) be
[
	if na eq 0 then
	 [ inputName="ACtemp";outputName="ACtemp"
	 ]
	let v=vec 1
	v!0=0
	MapACtemp(CheckOrbitIX, OrbitOne, v, inputName, outputName)
	TypeForm(10, v!0, " words of font storage.")
]

and CheckDeOrbitIX(ix) be
 [ unless ix>>IXH.Type eq IXTypeOrbitChars then
	[ Scream("DeOrbitize called with wrong input type");finish]
   ix>>IXH.Type=IXTypeChars
 ]

and DeOrbitOne(p, si, so, arg) be
[
	let masks=vec 17
	for i=0 to 16 do masks!i=(-1) rshift i

//Check for a character with no bits in it
	let hb= p>>CharWidth.H
	let widthFromCharWidth = p>>CharWidth.W
	test (hb eq 0) % (widthFromCharWidth eq 0)
	  ifso
		[
		let result = vec 0
		result!0=0
		WindowWriteBlock(so, result, 1)
		arg!0=arg!0+1
		p>>CharWidth.H = 0
		p>>CharWidth.W = 0
		p>>CharWidth.XL = 0
		p>>CharWidth.YB = 0
		]
	  ifnot
		[
		//Find out dimensions of char
		let a=WindowRead(si)
		let hhb= -a
		a=WindowRead(si)
		let ns= a+1
//Compare height in character with height in info block
		if hhb ne hb then Scream("Character height inconsistency")
//Compute height in words for DeOrbit output
		let hw=(hb+15)/16
//frag is the number of bits in last word of each scanline
		let frag=hb-16*(hw-1)
 		let sizeNeeded=ns*hw+1
		let pbits=FSGetX(sizeNeeded)
		pbits>>FHEAD.hw=hw	//Height
		pbits>>FHEAD.ns=ns	//Width
		let p,bp,w=pbits,0,nil
		for i=1 to ns do
			[
			for j=1 to hw-1 do //note that hw ge 1
				[
				p=p+1
				p!0=w lshift (16-bp)
				w=WindowRead(si)
				p!0=p!0 % (w rshift bp)
				]
			p=p+1 
			test bp ge frag ifso 
				[
				p!0=(w lshift (16-bp))&(not masks!frag)
				bp=bp-frag 
				]
			  ifnot
				[
				p!0=w lshift (16-bp)
				w=WindowRead(si)
				p!0=(p!0%(w rshift bp))&(not masks!frag)
				bp=16+bp-frag
				]
			]
		WindowWriteBlock(so, pbits, sizeNeeded)
		arg!0=arg!0+sizeNeeded
		FSPut(pbits)
		]
]

and CheckOrbitIX(ix) be
 [ unless ix>>IXH.Type eq IXTypeChars then
		[ Scream("Orbit format called with wrong input type");finish]
   ix>>IXH.Type=IXTypeOrbitChars
 ]

and OrbitOne(p, si, so, arg) be
[
	let masks=vec 16
	for i=0 to 15 do masks!i=(-1) rshift i

//Find out dimensions of char
	let a=WindowRead(si)
	let hw= a<<FHEAD.hw
	let ns=a<<FHEAD.ns
	let hb=p>>CharWidth.H
// Place here "hb=16*hw" if you want unpacked fonts.
	unless pack then [ hb=16*hw; p>>CharWidth.H=hb ]
//
	let hhw=(hb+15)/16
	if hhw ne hw then Scream("Character height inconsistency")
// sizeNeeded _ (hb*ns+15)/16
	let mul=vec 1
	DoubleMul(mul, hb, ns)
	DoubleAdd(mul, table [ 0;15 ] )
	let sizeNeeded=(mul!0 lshift 12)+(mul!1 rshift 4)
	if sizeNeeded eq 0 then
			[
			ns=0; hw=0; hb=0
			p>>CharWidth.H=0
			p>>CharWidth.W=0
			p>>CharWidth.YB=0
			p>>CharWidth.XL=0
			]
	sizeNeeded=(sizeNeeded+3)&(-2)		//Account for header; even num
	let pbits=FSGetX(sizeNeeded+1)	//1 extra because of p!1 below
	pbits!0=-hb		//Height
	pbits!1=ns-1	//Width
	let p=pbits+2
	let ob=0

	for i=1 to ns do
			[
			for j=1 to hw do
				[
				let w=WindowRead(si)
				p!0=(p!0&(not masks!ob))+(w rshift ob)
				p!1=(p!1&(masks!ob))+(w lshift (16-ob))
				p=p+1
				]
			ob=ob+hb
			p=p-hw+ob/16
			ob=ob&#17
			]
	WindowWriteBlock(so, pbits, sizeNeeded)
	arg!0=arg!0+sizeNeeded
	FSPut(pbits)
]

and DoubleMul(res, a, b) be
[
	let ad=vec 1
	ad!0=0; ad!1=a
	res!0=0; res!1=0
	for i=1 to b do DoubleAdd(res, ad)
]