// October 10, 1979  10:14 AM by Taft			*** RESIDENT ***
//Edited by Lyle Ramshaw September 4, 1980  2:55 PM:
// Hacked on text postioning; added isArrows flag checks
 
get "ZPDEFS.bcpl"


// outgoing procedures

external [
	incTextBuffer
	decTextBuffer
	refreshTextBuffer
	turnTextOn
	turnTextOff
	checkTextID
	newTextID
	complementBox
	makeText
	remakeText
	markText
	showText
	writeText
	rewriteText
	eraseText
	textColorSymbol
	fontAddress
	]


// outgoing statics

external [
	@maxStringHeight		// ZPCONVERT
	]

static [
	@maxStringHeight
	]


// incoming procedures

external [
	MoveBlock		// SYSTEM
	Zero
	CreateDiskStream
	Closes
	ReadBlock

	typeForm		// ZPUTIL

	obtainBlock		// ZPBLOCK
	putBlock
	giveUp

	paintString		// ZPCONVERT

	XORcolorSymbol		// ZPDRAW
	]


// incoming statics

external [
	@bitmap00		// ZPINIT
	@scanlineWidth
	@Xmax
	@Ymax
	@maxTextID
	@textTable
	@fontDefTable
	@fontFile
	@font
	@dspFont
	@dspFontAddress
	@textOK
	@textString
	@textWidth
	@textHeight
	@textBitmap
	@textBitmapSize

	@colorOn			// ZPEDIT
	]


// local definitions:

// ALTO font format

structure WX [
	wx	bit 15
	noExt	bit 1
	]

structure WXplus1 [
	skip	byte
	bits	byte
	]




//***************************************************
//  text command procedures
//***************************************************


let incTextBuffer(char) be [incTextBuffer
	if textOK then turnTextOff()
	let c=textString>>STRING.length+1
	unless c le maxChar return
	textString>>STRING.char↑c=char
	textString>>STRING.length=c
	refreshTextBuffer()
	]incTextBuffer


and decTextBuffer()be [decTextBuffer
	if textOK return
	let c=textString>>STRING.length
	unless c return
	textString>>STRING.length=c-1
	refreshTextBuffer()
	]decTextBuffer


and refreshTextBuffer() be [refreshTextBuffer
	clearTextBuffer()
	let stringLength=textString>>STRING.length
	if stringLength eq 0 return
	let fontPointer=fontAddress(font)
	textHeight=@(fontPointer-2)
	let textSkip=nil
	let arrowsHack=false
	if (stringLength eq 1)&
	  (fontDefTable!font>>FONTDEF.isArrows eq 1) then
	  arrowsHack=true
	textSize(arrowsHack, textString, fontPointer, lv textWidth, lv textHeight, lv textSkip)
	let destAd = textBitmap
	if arrowsHack then destAd = textBitmap-textSkip*scanlineWidth
	paintString(textString, scanlineWidth, 15, 
		destAd, fontPointer)
	if textOK then 
		complementBox(textBitmap, 0, textWidth, textHeight+1)
	]refreshTextBuffer



and turnTextOn() be [turnTextOn
	if textOK return
	textOK=textString>>STRING.length
	if textOK then
		complementBox(textBitmap, 0, textWidth, textHeight+1)
	]turnTextOn



and turnTextOff() be [turnTextOff
	unless textOK return
	clearTextBuffer()
	textOK=0
	textWidth=0
	textHeight=0
	textString>>STRING.length=0
	]turnTextOff


and clearTextBuffer() be [clearTextBuffer
	Zero(textBitmap, textBitmapSize)
	]clearTextBuffer



//***************************************************
//  "Box" procedures
//***************************************************


and complementBox(w0, b, boxWidth, boxHeight) be
	XORbox(w0, b, boxWidth, boxHeight, -1)


and XORbox(w0, b, boxWidth, boxHeight, p) be [XORbox
	let n=(boxWidth+b) rshift 4
	let s=((-1) rshift b) & p
	let r=((-1) lshift (16 - ((boxWidth+b) & #17))) & p
	unless n then [ s=s & r; r=0 ]
	for i=1 to boxHeight  do [
		@w0=@w0 xor s
		for w=w0+1 to w0+n-1 do @w=@w xor p
		if r then @(w0+n)=@(w0+n) xor r
		w0=w0 + scanlineWidth
		]
	]XORbox



and eraseBox(w0, b, boxWidth, boxHeight) be [eraseBox
	let n=(boxWidth+b) rshift 4
	let s=(-1) lshift (16-b)
	let r=(-1) rshift ((boxWidth+b) & #17)
	for i=1 to boxHeight  do [
		@w0=@w0 & s
		for w=w0+1 to w0+n-1 do @w=0
		if r then @(w0+n)=@(w0+n) & r
		w0=w0 + scanlineWidth
		]
	]eraseBox



and stripeBox(w0, b, boxWidth, boxHeight) be
	XORbox(w0, b, boxWidth, boxHeight, #146314)


//***************************************************
//  level 1 text procedures (parameter is text ID)
//***************************************************


and makeText(string, x, y, f, color, showIt; numargs n) = valof [makeText
	if n le 5 then showIt=true
	let id=createText(string, x, y, f, color)
	if showIt then showText(id)
	resultis id
	]makeText


and remakeText(textPointer) = valof [remakeText
	let id=newTextID()
	unless id resultis 0
	textTable!id=textPointer
	textTable!0=textTable!0+1
	showText(id)
	resultis id
	]remakeText



and createText(string, left, top, f, color, b; numargs n) = valof [createText
	let c=string>>STRING.length
	unless c resultis 0
	let id=newTextID()
	unless id resultis 0
	let textPointer=obtainBlock(TEXTblockSize+c/2+1)
	unless textPointer resultis giveUp("[makeText]")
	let textString=textPointer+TEXTblockSize
	MoveBlock(textString, string, c/2+1)
	textPointer>>TEXT.left=left
	textPointer>>TEXT.top=top
	textPointer>>TEXT.selected= (n ls 6) ? 0, b
	textPointer>>TEXT.tFlag=1
	textPointer>>TEXT.color=color
	setFont(textPointer, f)
	textTable!id=textPointer
	textTable!0=textTable!0+1
	resultis id
	]createText



and showText(id) be [showText
	writeText(checkTextID(id))
	]showText



and rewriteText(id) be [rewriteText
	let textPointer=checkTextID(id)
	unless textPointer return
	unless setFont(textPointer, font) return
	processBox(textPointer, eraseBox)
	textPointer>>TEXT.font=font
	writeText(textPointer)
	]rewriteText



and markText(id, b) be [markText
	let textPointer=checkTextID(id)
	unless textPointer return
	textPointer>>TEXT.selected=b
	processBox(textPointer, complementBox)
	]markText



and eraseText(id) be [eraseText
	let textPointer=checkTextID(id)
	textColorSymbol(textPointer)
	processBox(textPointer, eraseBox)
	]eraseText



and newTextID() = valof [newTextID
	for id=1 to maxTextID do
		unless textTable!id resultis id
	typeForm(0, "Sorry, no room for more than ", 10, maxTextID, 0, " text strings*N", 
		0, "To get more work space for text, start DRAW with switch /T (e.g.: DRAW ",
		10, 2*maxTextID, 0, "/T )*N")
	resultis 0
	]newTextID


and checkTextID(id) = ((id ls 1) % (id gr maxTextID)) ? 0, textTable!id



//***************************************************
//  level 0 text procedures (parameter is text pointer)
//***************************************************


and writeText(textPointer) be [writeText
	unless textPointer return
	let thisFont=textPointer>>TEXT.font
	let fontPointer=fontAddress(thisFont)
	let textString=textPointer+TEXTblockSize
	let arrowsHack=false
	if (textString>>STRING.length eq 1)&
	  (fontDefTable!thisFont>>FONTDEF.isArrows eq 1) then
	  arrowsHack=true
	let x=textPointer>>TEXT.left
	let y=textPointer>>TEXT.top
	let box=vec TEXTblockSize+1
	let h, w, skip=nil, nil, nil
	textSize(arrowsHack, textString, fontPointer, lv w, lv h, lv skip)
	textPointer>>TEXT.right=x+w-1
	textPointer>>TEXT.bottom=y-h+1
	textPointer>>TEXT.skip=skip
	MoveBlock(box, textPointer, TEXTblockSize)
	switchon clipBox(box) into [
	case 0:
		paintString(textString, 
			scanlineWidth, 
			(15-(x & #17)), 
			wordAddress(x,
				(arrowsHack ? y+skip, y))-scanlineWidth, 
			fontPointer)
		endcase
	case 1:
		return
	case 2:
		processBox(box, stripeBox)
		endcase
		]
	if textPointer>>TEXT.selected then
		processBox(textPointer, complementBox)
	textColorSymbol(textPointer)
	]writeText



and setFont(textPointer, fontNumber) = valof [setFont
	unless (fontNumber ge 0) & (fontNumber le 3) then fontNumber=0
	if textPointer>>TEXT.font eq fontNumber resultis 0
	textPointer>>TEXT.font=fontNumber
	resultis true
	]setFont


and textColorSymbol(textPointer) be [textColorSymbol
	unless textPointer return
	let textColor=textPointer>>TEXT.color
	unless colorOn & textColor ne black return
	XORcolorSymbol((textPointer>>TEXT.left + textPointer>>TEXT.right)/2,
			textPointer>>TEXT.bottom, textColor)
	]textColorSymbol



and processBox(textPointer, process) be [processBox
	unless textPointer return
	let box=vec 4
	box>>TEXT.left=textPointer>>TEXT.left-1
	box>>TEXT.top=textPointer>>TEXT.top+1
	box>>TEXT.right=textPointer>>TEXT.right+1
	box>>TEXT.bottom=textPointer>>TEXT.bottom-1
	if clipBox(box) eq 1 return
	let x=box>>TEXT.left
	let y=box>>TEXT.top
	process(wordAddress(x, y), 
		(x & #17), 
		box>>TEXT.right-x+1, 
		y-box>>TEXT.bottom+1)
	]processBox



and clipBox(box) = valof [clipBox
	let left=box>>TEXT.left
	let top=box>>TEXT.top
	let right=box>>TEXT.right
	let bottom=box>>TEXT.bottom
	// OK, no clipping
	if (left ge 0) & (right le Xmax)
	 & (top le Ymax) & (bottom ge 0) resultis 0
	// no display
	if (right ls 0) % (left gr Xmax)
	 % (bottom gr Ymax) % (top ls 0) resultis 1
	// clipping
	box>>TEXT.left= (left ls 0) ? 0, left
	box>>TEXT.top= (top gr Ymax) ? Ymax, top
	box>>TEXT.right= (right gr Xmax) ? Xmax, right
	box>>TEXT.bottom= (bottom ls 0) ? 0, bottom
	resultis 2
	]clipBox



and wordAddress(x, y) = (bitmap00 + (x rshift 4) - y*scanlineWidth)


and textSize(arrowsFlag, textPointer, fontPointer, widthAd, heightAd, skipAd; numargs n) be [textSize
	let w, hb, ht=0, 0, @(fontPointer-2)
	let stringLength=textPointer>>STRING.length
	for i=1 to stringLength do [
		let c=textPointer>>STRING.char↑i
		[ let wxpt=fontPointer+c+fontPointer!c
		  let newht=(wxpt+1)>>WXplus1.skip
		  let newhb=newht+(wxpt+1)>>WXplus1.bits
		  if newhb gr hb then hb=newhb
		  if newht ls ht then ht=newht
		  c=wxpt>>WX.wx
		  if wxpt>>WX.noExt
		  then [ w=w+c; break ]
		  w=w+16
		  ] repeat
		]
	switchon n into [
		case 6: @skipAd=(arrowsFlag ? ht, 0);
		case 5: @heightAd=(arrowsFlag ? hb-ht, (fontPointer-2)>>AL.height);
		case 4: @widthAd=w
		]
	]textSize



and fontAddress(f) = valof [fontAddress
	// is font in memory ??
	let fontLength=fontFile>>FONTFILE.length↑f
	test fontLength eq 0
	ifnot [
		// yes => is it the current font?
		let fontBuffer=fontFile>>FONTFILE.buffer
		if fontFile>>FONTFILE.current ne f then [
			let fontStream=CreateDiskStream(lv(fontFile>>FONTFILE.fp↑f), ksTypeReadOnly)
			ReadBlock(fontStream, fontBuffer, fontLength)
			Closes(fontStream)
			fontFile>>FONTFILE.current=f
			]
		resultis (fontBuffer+2)
		]
	ifso [
		// no => use the display font
		if f ne dspFont then
			typeForm(0, "No font ", 10, f, 0, ", message font used instead*N")
		resultis dspFontAddress
		]
	]fontAddress