// M E R G E D E L E T E O U T P U T  (PREPRESS)
//
// Does output for MergeDelete

//Modified by Lyle Ramshaw, PARC on December 27, 1980  10:09 PM:
//  changed storage allocation in the Verify case so that there
//  doesn't have to be enough free core for an entire character.

//Modified by Lyle Ramshaw, PARC on December 20, 1980  8:39 PM:
//  Added more typeout

//Modified by Lyle Ramshaw, PARC on September 28, 1980  8:41 PM:
//  Added code to implement Verified Mode:  perform compacting and checking
//  inside at the character level in blocks of AlignedChars, OrbitChars,
//  and MultiChars.
 
//Written by Lyle Ramshaw, PARC on May 20, 1980  12:48 PM    

get "Ix.dfs"
get "AltoFileSys.D"	//for STRING stuff
get "Streams.d"
get "MergeLists.d"

// outgoing procedures
external
	[
	MergeDeleteOutput
	]

// incoming procedures
external
	[
	PrePressWindowInit

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

//UTIL
	FSGetX
	FSPut

	ReadIX
	WriteIX
	CompareIX
	PrintIX
	ReadIXTempFile
	WriteIXTempFile
	TypeChar
	CheckParams
	Scream
	IllFormat
	IllCommand
	DblShift
	GetPosRelative

//SCAN
	StrEq
	StrCop
	TypeForm

//Float
	DPSB

//OS
	OpenFile
	DoubleAdd
	Min
	Max
	Zero
	SetBlock
	MoveBlock
	ReadCalendar
	Usc

//Filops
	FillIX
	]

// incoming statics
external
	[
	@verifyFlag	//from MergeDelete
	]

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

// Procedures

let MergeDeleteOutput(outNameList, outDataList, wOld, wNew,
			 careful, oldName) be
[
let DPZero= table [ 0;0 ]

//Compute length of IX portions of the output file
let nameWords=0
let p=outNameList
while p do
	[
	nameWords=nameWords+p>>NNode.ix.Length
	p=@p
	]
let dataWords=0
p=outDataList
while p do
	[
	dataWords=dataWords+(lv p>>DNode.ix)>>IXH.Length
	p=@p
	]
let ixWords=nameWords+dataWords+IXLEnd
let breakPos=vec 1
breakPos!0=0;  breakPos!1=ixWords

test careful ifso
  [
  //write new file in canonical order on PrePress.Scratch, then copy
  //it back to wOld
  let wTemp=PrePressWindowInit(0)
  WindowSetPosition(wTemp, breakPos)
  let p=outDataList
  while p do
	[
	//write the data segment described by this node
	let x=lv p>>DNode.ix
	switchon x>>IXH.Type into
		[
	  case IXTypeMultiChars:
		  [
		  let oldInFile,newInFile=nil,nil
		  let hardWay=false
		  switchon p>>DNode.file into
			[
			case 0: oldInFile=wOld;newInFile=wOld;endcase
			case 1: oldInFile=wNew;newInFile=wNew;endcase
			case 2: oldInFile=wOld;newInFile=wNew
				  hardWay=true;endcase
			]
		  let newReset=vec 1
		  MoveBlock(newReset,lv x>>IXM.segs^1.sa,2)
		  WindowSetPosition(newInFile,newReset)
		  WindowGetPosition(wTemp,lv x>>IXM.segs^1.sa)
		  MoveCharSegment(newInFile,wTemp,true,
			x, lv x>>IXM.segs^1.len)
		  for i=2 to x>>IXM.numSegs do
			[
			WindowSetPosition(oldInFile,lv x>>IXM.segs^i.sa)
			WindowGetPosition(wTemp,lv x>>IXM.segs^i.sa)
			test hardWay then
			  [
			  //In this block, we want to get the raster-
			  //dependent stuff from newInFile, the widths from
			  //the oldInFile;  compiled in sizes!!
			  compileif CharWidthsize ne 8 then [ foo=nil]
			  let v1,v2=vec CharWidthsize,vec CharWidthsize
			  WindowSetPosition(newInFile,newReset)
			  for j=x>>IXM.bc to x>>IXM.ec do
				[
				WindowReadBlock(newInFile,v1,CharWidthsize)
				WindowReadBlock(oldInFile,v2,CharWidthsize)
				WindowWriteBlock(wTemp,v2,4)	//widths
				WindowWriteBlock(wTemp,v1+4,4)  //raster stuff
				]
			  ]
			 or WindowCopy(oldInFile,wTemp,lv x>>IXM.segs^i.len)
			]
		  endcase
		  ] //end of MultiChars
	  case IXTypeOrbitChars:
		  [
		  let ifile=((p>>DNode.file eq 0)?wOld,wNew)
		  WindowSetPosition(ifile,lv x>>IX.sa)
		  WindowGetPosition(wTemp,lv x>>IX.sa)
		  MoveCharSegment(ifile,wTemp,true,
			x, lv x>>IX.len)
		  endcase
		  ]
	  case IXTypeChars:
		  [
		  let ifile=((p>>DNode.file eq 0)?wOld,wNew)
		  WindowSetPosition(ifile,lv x>>IX.sa)
		  WindowGetPosition(wTemp,lv x>>IX.sa)
		  MoveCharSegment(ifile,wTemp,false,
			x, lv x>>IX.len)
		  endcase
		  ]
	  default:
		  [
		  let ifile=((p>>DNode.file eq 0)?wOld,wNew)
		  WindowSetPosition(ifile,lv x>>IX.sa)
		  WindowGetPosition(wTemp,lv x>>IX.sa)
		  WindowCopy(ifile,wTemp,lv x>>IX.len)
		  ]
		]  //end of switchon
	p=@p
	TypeForm(".")
	]
  //remember total length of output file
  let tl=vec 1;  WindowGetPosition(wTemp,tl)

  //write the new headers, all new file pointers having been set up
  WindowSetPosition(wTemp, DPZero)
  p=outNameList
  while p do
	[
	WriteIX(wTemp, -1, lv p>>NNode.ix)
	p=@p
	]
  p=outDataList
  while p do
	[
	WriteIX(wTemp, -1, lv p>>DNode.ix)
	p=@p
	]
  WriteIX(wTemp, IXTypeEnd)

  //and copy back to oldFile
  WindowFlush(wTemp)
  TypeForm(0,"Valid output now available in PrePress.Scratch.",0)
  WindowSetPosition(wTemp,DPZero)
  WindowSetPosition(wOld,DPZero)
  WindowCopy(wTemp, wOld, tl)
  WindowClose(wOld, -1)
  TypeForm("Valid output now available in Dictionary file.",0)
  ] //end of output-writing code, careful case


 ifnot //careful
  [
  //live dangerously:  having computed length of IX portion of output, move
  //data blocks out of the way if necessary to make room for IX'es, add
  //new data blocks at the end, then write the new IX'es.
  //First, figure out max of current wOld length and ixWords 
  let endPos=vec 1
  WindowLength(wOld, endPos)
  if DPUsc(breakPos, endPos) eq 1 then
	MoveBlock(endPos, breakPos, 2)
  WindowSetPosition(wOld, endPos)
  //next, loop through the outDataList, copying all data blocks to after
  //endPos except for those that happen to be safely after breakPos.
  //We need a second stream for read access to the dictionary file
  let wRead=PrePressWindowInit(oldName, 0)
  p=outDataList
  while p do
	[
	let x=lv p>>DNode.ix
	switchon x>>IXH.Type into
		[
	  case IXTypeMultiChars:
		  [
		  let oldInFile,newInFile=nil,nil
		  let hardWay=false
		  switchon p>>DNode.file into
			[
			case 0: oldInFile=wRead;newInFile=wRead;endcase
			case 1: oldInFile=wNew;newInFile=wNew;endcase
			case 2: oldInFile=wRead;newInFile=wNew
				  hardWay=true;endcase
			]
		  let newReset=vec 1
		  MoveBlock(newReset,lv x>>IXM.segs^1.sa,2)
		  if p>>DNode.file ne 0 %
		      DPUsc(newReset,breakPos) ls 0 then
			[
			//copy first segment to a safe place
			WindowSetPosition(newInFile,newReset)
			WindowGetPosition(wOld,lv x>>IXM.segs^1.sa)
			WindowCopy(newInFile,wOld,lv x>>IXM.segs^1.len)
			TypeForm(".")
			]
		  for i=2 to x>>IXM.numSegs do
			[
			let thisSegPos=vec 1
			MoveBlock(thisSegPos,lv x>>IXM.segs^i.sa,2)
			if p>>DNode.file ne 0 %
		 	  DPUsc(thisSegPos,breakPos) ls 0 then
			  [
			  //copy this segment to a safe place
			  WindowSetPosition(oldInFile,thisSegPos)
			  WindowGetPosition(wOld,lv x>>IXM.segs^i.sa)
			  test hardWay then
			    [
			    //In this block, we want to get the raster-
			    //dependent stuff from newInFile, the widths from
			    //the oldInFile;  compiled in sizes!!
			    compileif CharWidthsize ne 8 then [ foo=nil]
			    let v1,v2=vec CharWidthsize,vec CharWidthsize
			    WindowSetPosition(newInFile,newReset)
			    for j=x>>IXM.bc to x>>IXM.ec do
				[
				WindowReadBlock(newInFile,v1,CharWidthsize)
				WindowReadBlock(oldInFile,v2,CharWidthsize)
				WindowWriteBlock(wOld,v2,4)	//widths
				WindowWriteBlock(wOld,v1+4,4)  //raster stuff
				]
			    ]
			   or WindowCopy(oldInFile,wOld,lv x>>IXM.segs^i.len)
			  ]
			]
		  endcase
		  ] //end of MultiChars
	 default:
		  [
		  if p>>DNode.file ne 0 %
		    DPUsc(lv x>>IX.sa,breakPos) ls 0 then
			[
			//must copy this guy at the end
			let ifile=((p>>DNode.file eq 0)?wRead,wNew)
			WindowSetPosition(ifile, lv x>>IX.sa)
			WindowGetPosition(wOld, lv x>>IX.sa)
			WindowCopy(ifile,wOld,lv x>>IX.len) 
			TypeForm(".")
			]
		  ] //end of default
		]  //end of switchon
	p=@p
	]
  WindowClose(wRead)
  //remember total length of output file
  let tl=vec 1;  WindowGetPosition(wOld,tl)

  TypeForm(0,"Entering critical section: dictionary temporarily invalid...",0)
  //write the new headers, all new file pointers having been set up
  WindowSetPosition(wOld, DPZero)
  p=outNameList
  while p do
	[
	WriteIX(wOld, -1, lv p>>NNode.ix)
	p=@p
	]
  p=outDataList
  while p do
	[
	WriteIX(wOld, -1, lv p>>DNode.ix)
	p=@p
	]
  WriteIX(wOld, IXTypeEnd)
  WindowClose(wOld,tl)
  TypeForm("Exiting critical section: dictionary OK once again.",0) 
  ] //end of output-writing code, risky case
] //of MergeDeleteOutput
			
and MoveCharSegment(inFile,outFile,orbitFlag,ix,lvlen) be
[
test verifyFlag
 ifnot WindowCopy(inFile,outFile,lvlen)
 ifso
 [
 //Copy the character segment, but reorder the raster blocks if necessary
 //to get them in charcode order, and also check that the width information
 //in the CharWidth blocks agrees with the raster blocks.
 let outStart,outBase,outEnd=vec 1,vec 1,vec 1
 let inBase=vec 1
 let nc=ix>>IX.ec - ix>>IX.bc + 1
 let CW=FSGetX(CharWidthsize*nc)
 let CP=FSGetX(2*nc)
 WindowGetPosition(outFile,outStart)
 WindowReadBlock(inFile,CW,CharWidthsize*nc)
 WindowWriteBlock(outFile,CW,CharWidthsize*nc)
 WindowGetPosition(inFile,inBase)
 WindowGetPosition(outFile,outBase)
 WindowReadBlock(inFile,CP,2*nc)
 WindowWriteBlock(outFile,CP,2*nc)  //These pointers aren't correct, but
	// we will rewrite them later.
 for c=0 to nc-1 do
	[
	//process one character
	let w,h=nil,nil
	let thiscw=CW+CharWidthsize*c
	w=thiscw>>CharWidth.W
	h=thiscw>>CharWidth.H
	if h eq -1 then
		[
		//sanitize missing character
		Zero(thiscw,CharWidthsize)
		thiscw>>CharWidth.H=-1
		(CP+2*c)!0=-1; (CP+2*c)!1=-1;
		loop
		]
	let rasterpos=vec 1
	MoveBlock(rasterpos,inBase,2)
	DoubleAdd(rasterpos,CP+2*c)
	if h eq 0 % w eq 0 then
		[
		//empty raster:  just write the canonical empty
		//raster block, ignoring the input file.
		thiscw>>CharWidth.H=0
		thiscw>>CharWidth.W=0
		thiscw>>CharWidth.YB=0
		thiscw>>CharWidth.XL=0
		GetPosRelative(outFile,outBase,CP+2*c)
		test orbitFlag
		 ifso WindowWriteBlock(outFile,table [ 0;-1 ] ,2)
		 ifnot WindowWriteBlock(outFile,table [ 0 ],1)
		loop
		]
	test orbitFlag
	  ifso [
		let totalbits=vec 1
		DPMult(h,w,totalbits)
		DoubleAdd(totalbits, table [ 0;15 ] )
		DblShift(totalbits, 4)   //divide by 16
		if totalbits!0 ne 0 then
			[
			Scream("Ridiculously large character in Orbit format")
			finish
			]
		let sizeNeeded=((totalbits!1)+3)&(-2)
			 //2 word header and must be even length
		WindowSetPosition(inFile,rasterpos)
		let rasterHead=vec 2
		WindowReadBlock(inFile,rasterHead,2)
		if rasterHead!0 ne -h then 
			[
			TypeForm(0,"In font: ")
			PrintIX(ix); TypeForm("Char ",8,ix>>IX.bc+c, " ")
			Scream(" Height in CharWidth does not agree with height in raster block!")
			]
		if rasterHead!1 ne w-1 then
			[
			TypeForm(0,"In font: ")
			PrintIX(ix); TypeForm("Char ",8,ix>>IX.bc+c, " ")
			Scream(" Width in CharWidth does not agree with width in raster block!")
			]
		GetPosRelative(outFile,outBase,CP+2*c)
		WindowSetPosition(inFile,rasterpos)
		let DPsizeNeeded=vec 1
		DPsizeNeeded!0=0; DPsizeNeeded!1=sizeNeeded
		WindowCopy(inFile,outFile,DPsizeNeeded)
		]
	  ifnot
		[
		let hwords=(h+15)/16
		let sizeNeeded=(hwords*w)+1 // +1 is for header
		WindowSetPosition(inFile,rasterpos)
		let hdr=WindowRead(inFile)
		if hdr<<FHEAD.hw ne hwords then 
			[
			TypeForm(0,"In font: ")
			PrintIX(ix); TypeForm("Char ",8,ix>>IX.bc+c, " ")
			Scream(" Height in CharWidth does not agree with height in raster block!")
			]
		if hdr<<FHEAD.ns ne w then
			[
			TypeForm(0,"In font: ")
			PrintIX(ix); TypeForm("Char ",8,ix>>IX.bc+c, " ")
			Scream(" Width in CharWidth does not agree with width in raster block!")
			]
		GetPosRelative(outFile,outBase,CP+2*c)
		WindowSetPosition(inFile,rasterpos)
		let DPsizeNeeded=vec 1
		DPsizeNeeded!0=0; DPsizeNeeded!1=sizeNeeded
		WindowCopy(inFile,outFile,DPsizeNeeded)
		]
	]
 //Now copy the updated CP table to the outFile
 WindowGetPosition(outFile,outEnd)
 WindowSetPosition(outFile,outBase)
 WindowWriteBlock(outFile,CP,nc*2)
 WindowSetPosition(outFile,outEnd)
 //and reset the length of segment
 MoveBlock(lvlen,outEnd,2)
 DPSB(lvlen,outStart)
 FSPut(CP);
 FSPut(CW);
 ]
]

and DPMult(a,b,lvres) be
[
//set two word block pointed to by lvres to the product of the
//sixteen bit unsigned integers in a and b.  Technique is to
//split up into bytes:
let ahigh, alow, bhigh, blow = nil,nil,nil,nil
ahigh=a rshift 8
bhigh=b rshift 8
alow=a & #377
blow=b & #377
lvres!0=0; lvres!1=ahigh*bhigh
DblShift(lvres,-8)  //shift it left 8 bits
let temp=vec 1
temp!0=0; temp!1=ahigh*blow
DoubleAdd(lvres,temp)
temp!1=alow*bhigh
DoubleAdd(lvres,temp)
DblShift(lvres,-8)
temp!1=alow*blow
DoubleAdd(lvres,temp)
]

and DPUsc(a,b) = valof
[
let r=Usc(a!0,b!0)
if r then resultis r
resultis Usc(a!1, b!1)
]

(1792)\2292f1 1970f0 1571f1 1996f0