// February 21, 1978  11:22 AM				*** overlay B ***
//Edited by Lyle Ramshaw September 8, 1980  9:01 PM:
// On to version 5.0, with a new file format to get text positioning
// done reasonably (and consistent with ReDRaw).

 
// Compile with STATS/M to get STATISTICS code  [command <ctrl>Y]
// Compile with BITMAP/M to get BITMAP code  [command <ctrl>B]


get "zpDefs.bcpl"


// outgoing procedures:

external [
	readPicture
	writePicture
	writeStatistics
	writeBitmap
	changeTextMode
	readHelp
	readFont
	]

// outgoing static:

external [
	@help
	]

static [
	@help=0
	]


// incoming procedures:

external [
	Gets			// SYSTEM
	Puts
	Endofs
	Resets
	Closes
	OpenFile
	OpenFileFromFp
	FindFdEntry
	FileLength
	ReadBlock
	WriteBlock
	Zero
	MoveBlock

	giveUp			// ZPUTIL
	confirm
	sTypeForm
	typeForm
	getLine
	openRead
	openWrite
	abortMessage
	capitalize
	equal

	makeSpline		// ZPMAKE

	makeText		// ZPTEXT
	writeText
	eraseText
	showText

	obtainBlock		// ZPBLOCK
	putBlock
	flushDTTstack

	MakeFontEntry		// ZPFONTIO

	adjustText		// ZPADJUST
	]


// incoming statics:

external [
	fpSysDir		// SYSTEM
	keys

	@splineTable		// ZPINIT
	@textTable
	@maxSplineID
	@maxTextID
	@fontDefTable
	@fontFile
	@font
	@dspFont
	@bitmap
	@height
	@width
	@scanlineWidth
	@bitmapSize

	FLDI; FST		// FLOAT

	@posTextMode		// ZPEDIT
	@colorOn
	]


// local definitions:
  
manifest [
	getStatistics= not newname STATS
	getBitmap= not newname BITMAP
	]


// local statics:

static [
	@BMheight=0
	@BMwordWidth=0
	]


// local definitions

structure CHAIN [
	run^1, 1000 byte
	]

structure RUN [
	blank byte
	octant bit 3
	count bit 5
	]

// old file format

structure OFfirstWord [
	fp bit
	M bit 15
	]

structure OFheader [
	dashed bit
	cyclic bit
	blank bit 2
	shape bit 2
	thickness bit 2
	nKnots byte
	]

// new file formats (after version 3.0, first two words are 0;
//   after version 5.0, first two words are -1)

structure NFheader1 [
	blank bit 3
	[ dashed bit
	  shape bit 2
	  thickness bit 2 ] = [ brush bit 5 ]
	blank bit 5
	color bit 3
	]

structure NFheader2 [
	cyclic bit
	nKnots bit 15
	]
	

//****************************************************************
// Special commands: statistics & bitmap output
//****************************************************************


let writeStatistics() be [writeStatistics
compileif getStatistics then [
	let statFile=openWrite("*NWrite statistics on text file: ", charItem)
	unless statFile return
	let histVec= vec 256
	Zero(histVec, 256)
	typeForm(0, "Type comments terminated with 2 <return>s:*N")
	[ let c=getLine()
	  unless c break
	  sTypeForm(statFile, 0, c, 1, $*N)
	  putBlock(c)
	  ] repeat
	let k, c=0, 0
	for id=1 to maxSplineID do [
		let splinePointer=splineTable!id
		unless splinePointer loop
		let nKnots=splinePointer>>SPLINE.nKnots
		k=k+SPLINEknotBase+4*nKnots
		let nBeads=splinePointer>>SPLINE.nBeads
		unless nBeads loop
		sTypeForm(statFile, 0, "*NSPLINE ", 10, id, 1, $*N, 
			10, nKnots, 0, " knots*N", 10, nBeads, 0, " beads*N")
		let chainPointer=splinePointer>>SPLINE.chain
		let chainCountPointer=chainPointer+nBeads*(BEADsize+2)
		let runCount=@(chainCountPointer-1)
		let countBlockSize=(runCount+1)/2
		sTypeForm(statFile, 0, "chain storage: ", 10, BEADsize*nBeads, 1, $+, 
			10, 2*nBeads, 1, $+, 10, countBlockSize)
		let s=nBeads*(BEADsize+2)+countBlockSize
		c=c+s
		sTypeForm(statFile, 1, $=, 10, s, 1, $*N)
		let r=(chainCountPointer>>CHAIN.run^1)<<RUN.count
		let q=(chainCountPointer>>CHAIN.run^1)<<RUN.octant
		for k=2 to runCount do [
			let r1=(chainCountPointer>>CHAIN.run^k)<<RUN.count
			let q1=(chainCountPointer>>CHAIN.run^k)<<RUN.octant
			test q1 eq q
			ifso r=r+r1
			ifnot [
				if r gr 255 then r=255
				histVec!r=histVec!r+1
				r=r1
				q=q1
				]
			]
		if r gr 255 then r=255
		histVec!r=histVec!r+1
		]
	let t=0
	for id=1 to maxTextID do [
		let textPointer=textTable!id
		unless textPointer loop
		t=TEXTblockSize+(textPointer+TEXTblockSize)>>STRING.length/2+1
		]
	sTypeForm(statFile, 0, "*N*NTotal storage:*NKnots: ", 10, k, 
		0, "*NChain: ", 10, c, 0, "*NText: ", 10, t)
	sTypeForm(statFile, 0, "*NTotal: ", 10, k+c+t, 1, $*N)
	Closes(statFile)

	let histFile=openWrite("*NWrite histogram on binary file: ", wordItem)
	unless histFile return
	WriteBlock(histFile, histVec, 256)
	Closes(histFile)
	typeForm(0, "Done*N")
	]
	]writeStatistics



and writeBitmap() be [writeBitmap
compileif getBitmap then [
	typeForm(0, "[Set statics BMheight & BMwordWidth]")
	let file=openWrite("*NWrite BITMAP on file: ", wordItem)
	unless file return
	let bm=bitmap+margin+(height-BMheight)*scanlineWidth
	Puts(file, BMheight)
	Puts(file, BMwordWidth)
	for s=1 to BMheight do [
		WriteBlock(file, bm, BMwordWidth)
		bm=bm+scanlineWidth
		]
	Closes(file)
	typeForm(0, "Done*N")
	]
	]writeBitmap



//****************************************************************
// Standard spline input/output
//****************************************************************


and readPicture(file; numargs n) be [readPicture
	let M,T=nil,nil
	let newIdTable=0
	flushDTTstack()
	unless n then
		file=openRead("*NRead picture from file: ", wordItem)
	unless file return
	let word1=Gets(file)
	let word2=Gets(file)
	let convertText=true	//iff text must be converted to >=5.0 format
	if (word1 eq -1) & (word2 eq -1) then convertText=false
	test (word1 eq word2) & ((word2 eq 0)%(word2 eq -1))
	ifso [
		// new file format
		M=Gets(file)
		for m=1 to M do [
			let header1=Gets(file)
			let header2=Gets(file)
			let n=header2<<NFheader2.nKnots
			unless n gr 0 loop
			let xTable=obtainBlock(4*n)
			test xTable ne 0
			ifso [
				ReadBlock(file, xTable, 4*n)
				makeSpline(n, xTable, xTable+2*n,
						header1<<NFheader1.brush,
						header1<<NFheader1.color,
						header2<<NFheader2.cyclic)
				putBlock(xTable)
				]
			ifnot [
				giveUp("[readPicture.1]")
				for i=1 to 4*n do Gets(file)
				]
			]
		T= Endofs(file) ? 0, Gets(file)
		if T ne 0 then [
			newIdTable=obtainBlock(T)
			if newIdTable eq 0 then [
				giveUp("[readPicture.2]")
				Closes(file)
				return
				]
			]
		for t=0 to T-1 do [
			let textString= vec maxChar
			let left=Gets(file)
			let top=Gets(file)
			let font=Gets(file)
			let color=Gets(file)
			let s=Gets(file)
			ReadBlock(file, textString, s)
			newIdTable!t=
				makeText(textString, left, top, font, color, false)
			]
		]
	ifnot [
		// old file format
		Resets(file)
		word1=Gets(file)
		let fp=word1<<OFfirstWord.fp
		M=word1<<OFfirstWord.M
		if M then [
			let hTable=obtainBlock(M)
			unless hTable then [
				giveUp("[readPicture.3]")
				Closes(file)
				return
				]
			ReadBlock(file, hTable, M)
			for i=0 to M-1 do [
				let header=hTable!i
				let n=header<<OFheader.nKnots
				unless n gr 0 loop
				let xTable=obtainBlock(4*n)
				test xTable ne 0
				ifso [
					test fp
					ifso ReadBlock(file, xTable, 4*n)
						//for old integer format files!
					ifnot for k=0 to 2*n-1 do
						FST(FLDI(0, Gets(file)), xTable+2*k)
					let brush=0
					brush<<BRUSH.dashed=header<<OFheader.dashed
					brush<<BRUSH.shape=header<<OFheader.shape
					brush<<BRUSH.thickness=header<<OFheader.thickness
					makeSpline(n, xTable, xTable+2*n, brush, black,
							header<<OFheader.cyclic)
					putBlock(xTable)
					]
				ifnot [
					giveUp("[readSpline.4]")
					for i=1 to (fp ? 4*n, 2*n) do Gets(file)
					]
				]
			putBlock(hTable)
			]
		// then read text
		T= Endofs(file) ? 0, Gets(file)
		if T then [
			newIdTable=obtainBlock(T)
			unless newIdTable then [
				giveUp("[readPicture.5]")
				Closes(file)
				return
				]
			ReadBlock(file, newIdTable, T)
			for t=0 to T-1 do [
				let tTable=vec (maxChar+4)
				ReadBlock(file, tTable, newIdTable!t+4)
				newIdTable!t= makeText(tTable+4, tTable!0,
						tTable!1, tTable!2, black, false)
				]
			]
		]
	Closes(file)
	// now, display text!
	if T ne 0 then for f=0 to maxFont-1 do [
		for t=0 to T-1 do [
			let textPointer=textTable!(newIdTable!t)
			unless textPointer loop
			unless textPointer>>TEXT.font eq f loop
			if convertText then adjustText(textPointer)
			writeText(textPointer)
			]
		]
	putBlock(newIdTable)
	typeForm(0, "Done!*N")
	]readPicture



and writePicture(file; numargs n) be [writePicture
	let M=splineTable!0
	let T=textTable!0
	unless M % T return
	unless n then
		file=openWrite("*NWrite picture on file: ", wordItem)
	unless file return
	Puts(file, -1)
	Puts(file, -1)
	// splines
	Puts(file, M)
	if M then for id=1 to maxSplineID do [
		let splinePointer=splineTable!id
		unless splinePointer loop
		let header1=0
		header1<<NFheader1.brush=splinePointer>>SPLINE.brush
		header1<<NFheader1.color=splinePointer>>SPLINE.color
		Puts(file, header1)
		let header2=splinePointer>>SPLINE.nKnots
		header2<<NFheader2.cyclic=splinePointer>>SPLINE.cyclic
		Puts(file, header2)
		WriteBlock(file, splinePointer+SPLINEknotBase, 
				4*splinePointer>>SPLINE.nKnots)
		]
	// text
	Puts(file, T)
	if T then for f=0 to maxFont-1 do [
		for t=1 to maxTextID do [
			let textPointer=textTable!t
			unless textPointer loop
			if textPointer>>TEXT.font ne f loop
			Puts(file, textPointer>>TEXT.left)
			Puts(file, textPointer>>TEXT.top)
			Puts(file, textPointer>>TEXT.font)
			Puts(file, textPointer>>TEXT.color)
			let s=((textPointer+TEXTblockSize)>>STRING.length)/2 + 1
			Puts(file, s)
			WriteBlock(file, textPointer+TEXTblockSize, s)
			]
		]

	Closes(file)
	typeForm(0, "Done!*N")
	]writePicture



//****************************************************************
// Text centering mode
//****************************************************************


and changeTextMode() be [changeTextMode
	typeForm(0, "Text positioning mode [Center, Top, Left, Bottom, Right]: ")
	posTextMode=0
	until posTextMode do posTextMode=selecton capitalize(Gets(keys)) into [
		case $B: posTextBottom;
		case $C: posTextCenter;
		case $L: posTextLeft;
		case $R: posTextRight;
		case $T: posTextTop;
		default:  0
		]
	typeForm(0, selecton posTextMode into [
		case posTextCenter: "Center*N";
		case posTextTop: "Top*N";
		case posTextBottom: "Bottom*N";
		case posTextLeft: "Left*N";
		case posTextRight: "Right*N"
		])
	]changeTextMode


//****************************************************************
// HELP!
//****************************************************************


and readHelp() be [readHelp
	unless help return
	let fileName=vec 8
	let nextFileName=vec 8
	manualPage(help, fileName)
	help=help+1
	manualPage(help, nextFileName)
	let systemDir=OpenFileFromFp(fpSysDir, ksTypeReadOnly)
	if FindFdEntry(systemDir, nextFileName) eq -1 then help=1
	Closes(systemDir)
	let file=OpenFile(fileName, ksTypeReadOnly)
	test file
	ifso [
		readPicture(file)
		typeForm(0, "*N*N*NTo obtain next manual page (", 
			10, help, 0, ") type line-feed (<LF>)*N", 
			0, "To disable on-line manual, type <ctrl>? again.*N")
		]
	ifnot typeForm(0, "On-line manual is not there! Disable help mode with <ctrl>?*N")
	]readHelp


and manualPage(n, fileName) be [manualPage
	let moreThan10= n ge 10
	MoveBlock(fileName, (moreThan10 ? "MANUAL10.DRAW", "MANUAL0.DRAW"), 8)
	fileName>>STRING.char^(moreThan10 ? 8, 7)=$0+(moreThan10 ? (n-10), n)
	]manualPage



//****************************************************************
// Font
//****************************************************************


and readFont() = valof [readFont
	typeForm(0, "Load font ")
	for f=0 to maxFont-1 do if f ne dspFont then
		typeForm(8, f, 0, ((f eq maxFont-1) ? " ? ", ", "))
	let f=nil
	[ f=Gets(keys)-$0
	  if (f ne dspFont) & (f ge 0) & (f le 3) break
	  if (f ls 0) % (f gr 9) resultis abortMessage()
	  ] repeat
	typeForm(10, f)
	if not readFontFile(f) & (f eq font) then font=dspFont
	for id=1 to maxTextID do [
		let textPointer=textTable!id
		unless textPointer loop
		if textPointer>>TEXT.font eq f then [
			eraseText(id)
			showText(id)
			]
		]
	typeForm(0, "Done!*N")
	]readFont



and readFontFile(f) = valof [readFontFile
	let numberCodeTable= table [
		#400+$0; #400+$1; #400+$2; #400+$3 ]
	fontFile>>FONTFILE.current=-1
	fontFile>>FONTFILE.length^f=0
	let fontName=0
	let fontFileFp=vec lFP
	let file=openRead("*NRead font file: ", wordItem, lv fontName, fontFileFp)
	if file ne 0 then [
		let fontLength=FileLength(file)/2+1
		Resets(file)
		let ALheader=vec 2
		ReadBlock(file, ALheader, 2)
		Closes(file)
		fontFile>>FONTFILE.height^f=ALheader>>AL.height
		fontFile>>FONTFILE.baseline^f=ALheader>>AL.baseline
		fontFile>>FONTFILE.length^f=fontLength
		MoveBlock(lv(fontFile>>FONTFILE.fp^f), fontFileFp, lFP)
		]

	// get new buffer, as appropriate
	let maxLength=0
	let oldLength=fontFile>>FONTFILE.bufferLength
	for i=0 to maxFont-1 do
		if maxLength ls fontFile>>FONTFILE.length^i then
			maxLength=fontFile>>FONTFILE.length^i
	if maxLength ne oldLength then [
		putBlock(fontFile>>FONTFILE.buffer)
		let newBuffer=0
		if maxLength ne 0 then [
			newBuffer=obtainBlock(maxLength)
			if newBuffer eq 0 then [
				// forget it, keep old buffer
				giveUp("[readFont]")
				fontFile>>FONTFILE.length^f=0
				newBuffer=obtainBlock(oldLength)
				maxLength=oldLength
				]
			]
		fontFile>>FONTFILE.buffer=newBuffer
		fontFile>>FONTFILE.bufferLength=maxLength
		]

	let r= file eq 0 ? 0, MakeFontEntry(fontName, fontDefTable!f, f)
	putBlock(fontName)
	resultis r
	]readFontFile