// February 21, 1978  3:02 PM				*** RESIDENT ***

get "zpDefs.bcpl"


// outgoing procedures:

external [
	checkPoint
	startCode
	endCode
	beadHit
	checkSplineID
	curve
	drawSpline
	eraseSpline
	markSpline
	XORdot
	XORcolorSymbol
	splineColorSymbol
	giveMeXY
	erase
	draw
	initBitBlt
	BitBlt
	]


// outgoing statics:

external [
	// for communication with ZPMAKE
	@newX
	@newY
	// dashing:
	@dashOn
	@dashOff
	@dashCount
	@dashDraw
	@dashMode
	]

static [
	@newX
	@newY
	// dashing:
	@dashOn=0
	@dashOff=0
	@dashCount=0
	@dashDraw=-1
	@dashMode=0
	]


// incoming procedures:

external [
	MoveBlock		// SYSTEM
	Zero

	FLDI			// FLOAT
	FLD
	FTR
	FDV
	FSTDP
	DPAD

	trimBlock		// ZPBLOCK
	obtainBlock

colorSymbol		// ********** TEMP
	]


// incoming statics:

external [
	@bitmap00		// ZPINIT
	@bitmap
	@scanlineWidth
	@Xmax
	@Ymax
	@splineTable
	@maxSplineID

	@colorOn			// ZPEDIT

	brushFont		//ZPCONVERT
	]


// local statics:

static  [
	@curX
	@curY
	@oldX
	@oldY
	@olderX
	@olderY
	@octant
	@evenOctant
	@oddOctant
	@chainWord
	@chainWordPointer
	@chainBitPointer
	@chainCount
	@chainCountWord
	@chainCountPointer
	@chainByteCount
	@chainByteCountMax
	@beadPointer
	@beadX
	@beadY
	@beadIndex
	@beadIndexMax
	@curLeft
	@curRight
	@curTop
	@curBottom
	@curveBBC=0
	]


// local definitions:

manifest [
	beadFlag=not newname DEBUG
	firstBit=15
	chainCountMax=32
	]

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

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


//*****************************************************************
// select contiguous points (i.e check point overlap, gaps, L patterns)
//*****************************************************************

let checkPoint() be [checkPoint
	//caution: temporary floating Point registers
	manifest [ temp=0; dX=1; dY=2 ]
	let deltaX=(newX gr curX) ? newX-curX, curX-newX
	let deltaY=(newY gr curY) ? newY-curY, curY-newY
	//same points ?
	unless deltaX % deltaY then return
	//gap ?
	test deltaX gr 1 % deltaY gr 1 then [
		//linear interpolation
		let x=vec 2; let dpdX=vec 2
		let y=vec 2; let dpdY=vec 2
		let m=(deltaX gr deltaY) ? deltaX, deltaY
		FLDI(temp, m)
		FSTDP(FDV(FLDI(dX, newX-curX), temp), dpdX)
		FSTDP(FDV(FLDI(dY, newY-curY), temp), dpdY)
		x!0=curX; x!1=0
		y!0=curY; y!1=0
		for i=1 to m do [
			newX=DPAD(x, dpdX)
			newY=DPAD(y, dpdY)
			encodePoint()
			]
		]
	or encodePoint()
	]checkPoint



//*****************************************************************
// chain encoding
//*****************************************************************


and initChain(splinePointer, b0, bn; numargs n) be [initChain
	let nBeads=splinePointer>>SPLINE.nBeads
	let chainPointer=splinePointer>>SPLINE.chain
	switchon n into [
		case 1:	b0=1
		case 2:	bn=nBeads
		default:
				endcase
		]
	//set-up chain encoding globals
	beadIndex=(b0-1)*BEADsize+1
	beadIndexMax=bn*BEADsize+1
	chainWordPointer=chainPointer + beadIndex-1
	chainWord=@chainWordPointer
	chainBitPointer=firstBit
	let beadStart=chainPointer + nBeads*BEADsize
	beadPointer=beadStart + (b0-1)*2
	chainByteCount=(b0 eq 1) ? 0, beadStart!(2*b0-3)
	chainByteCountMax=beadStart!(bn*2-1)
	chainCountPointer=chainPointer + nBeads*(BEADsize+2) +
		(chainByteCount rshift 1)
	chainCountWord=@chainCountPointer
	if chainByteCount<<odd then
		chainCountWord=chainCountWord rshift 8
	chainCount=0
	]initChain



and startCode(splinePointer, startX, startY) be [startCode
	//set-up globals
	initChain(splinePointer)
	chainWord=0
	chainCountWord=0
	olderX, olderY=startX, startY
	oldX, oldY=olderX, olderY
	curX, curY=olderX, olderY
	beadX, beadY=olderX, olderY
	//display first point:
	initEraseDraw(splinePointer, drawMode)
	draw(curX, curY)
	curLeft, curRight, curTop, curBottom=curX, curX, curY, curY
	]startCode



and endCode(splinePointer) be [endCode
	//encode last two points: old* & cur*
	for i=1 to 2 do [
		//extrapolated dummy values...
		newX=curX+curX-oldX
		newY=curY+curY-oldY
		encodePoint()
		]
	//put window definition
	splinePointer>>SPLINE.left=curLeft
	splinePointer>>SPLINE.right=curRight
	splinePointer>>SPLINE.top=curTop
	splinePointer>>SPLINE.bottom=curBottom
	//end of chain encoding
	let nBeads=splinePointer>>SPLINE.nBeads
	let beadCount=(beadIndex-1)/BEADsize
	let chainPointer=splinePointer>>SPLINE.chain
	//store chain code word ?
	if (chainBitPointer ne firstBit) & (beadIndex ls beadIndexMax) then
		@chainWordPointer=chainWord rshift (chainBitPointer+1)
	//one more bead ?
	if (chainBitPointer ne firstBit) % ((beadIndex-1) rem BEADsize) then [
		putBead()
		beadCount=beadCount+1
		]
	//store count word ?
	if chainByteCount<<odd then @chainCountPointer=chainCountWord
	//compact storage
	if beadCount ls nBeads then [
		MoveBlock(chainPointer+beadCount*BEADsize, 
			chainPointer+nBeads*BEADsize, 2*beadCount)
		MoveBlock(chainPointer+beadCount*(BEADsize+2), 
			chainPointer+nBeads*(BEADsize+2), 
			(chainByteCount+1)/2)
		splinePointer>>SPLINE.nBeads=beadCount
		trimBlock(chainPointer, 
			chainPointer+beadCount*(BEADsize+2)+(chainByteCount+1)/2)
		]
	compileif beadFlag then [ showBeads(splinePointer, drawMode) ]
	showSelect(splinePointer)
	resetEraseDraw()
	]endCode



and encodePoint() be [encodePoint
	//if new*, cur* & old* in "L" pattern
	// or if new*=cur*
	// then drop cur*, else encode old*

	//    code   deltaXY  deltaX  deltaY  next    octants
	//	0	5	1	0	2	0/7
	//	1	8	1	1	1	0/1
	//	0	7	0	1	8	2/1
	//	1	6	-1	1	7	2/3
	//	0	3	-1	0	6	4/3
	//	1	0	-1	-1	5	4/5
	//	0	1	0	-1	4	6/5
	//	1	2	1	-1	3	6/7

	let evenOctantTable=table [ 4; 6; 6; 4; -1; 0; 2; 2; 0 ]
	let oddOctantTable=table [ 5; 5; 7; 3; -1; 7; 3; 1; 1 ]
	let oneBitCode=table [ 1; 0; 1; 0; -1; 0; 1 ; 0; 1 ]

	unless (((newX gr oldX) ? newX-oldX, oldX-newX) le 1)
	 & (((newY gr oldY) ? newY-oldY, oldY-newY) le 1) then [
		let deltaXY=(oldX-olderX+1)+3*(oldY-olderY+1)
		if deltaXY ne 4 then [
			let possibleEvenOctant=evenOctantTable!deltaXY
			let possibleOddOctant=oddOctantTable!deltaXY
			test chainCount eq 0
			ifso [
				//start of a new run
				evenOctant=possibleEvenOctant
				oddOctant=possibleOddOctant
				]
			ifnot test possibleEvenOctant ne evenOctant
				& possibleOddOctant ne oddOctant
			ifso [
				//no octant match
				putCount()
				evenOctant=possibleEvenOctant
				oddOctant=possibleOddOctant
				]
			ifnot [
				//one or more octant match
				if possibleEvenOctant ne evenOctant then
						evenOctant=-1
				if possibleOddOctant ne oddOctant then
						oddOctant=-1
				]
			putCode(oneBitCode!deltaXY)

			//also display point
			draw(oldX, oldY)
			test oldX gr curRight
				ifso curRight=oldX
				ifnot if oldX ls curLeft then curLeft=oldX
			test oldY gr curTop
				ifso curTop=oldY
				ifnot if oldY ls curBottom then curBottom=oldY
			]
		olderX, olderY=oldX, oldY
		oldX, oldY=curX, curY
		]
	curX, curY=newX, newY
	]encodePoint



//**************************************************************
// storing bit code, bead & count
//**************************************************************


and putCode(oneBit) be [putCode
	chainWord=chainWord rshift 1
	if oneBit then chainWord=chainWord % #100000
	chainCount=chainCount+1
	test chainBitPointer eq 0
	ifso if beadIndex ls beadIndexMax then [
		@chainWordPointer=chainWord
		chainWordPointer=chainWordPointer+1
		chainWord=0
		chainBitPointer=firstBit
		//start a new bead ?
		unless beadIndex rem BEADsize then putBead()
		beadIndex=beadIndex+1
		]
	ifnot chainBitPointer=chainBitPointer-1
	if chainCount eq chainCountMax then putCount()
	]putCode


and putBead() be [putBead
	putCount()
	@beadPointer=0
	test oldX ge beadX
	ifso [
		beadPointer>>BEADXY.xDir=1
		beadPointer>>BEADXY.deltaX=oldX-beadX
		]
	ifnot beadPointer>>BEADXY.deltaX=beadX-oldX
	test oldY ge beadY
	ifso [
		beadPointer>>BEADXY.yDir=1
		beadPointer>>BEADXY.deltaY=oldY-beadY
		]
	ifnot beadPointer>>BEADXY.deltaY=beadY-oldY
	@(beadPointer+1)=chainByteCount
	beadX, beadY=oldX, oldY
	beadPointer=beadPointer+2
	]putBead


and putCount() be [putCount
	unless chainCount return
	chainCountWord<<PUTCHAIN.octant=
		(evenOctant eq -1) ? oddOctant, evenOctant
	chainCountWord<<PUTCHAIN.count=chainCount-1
	chainCount=0
	chainByteCount=chainByteCount+1
	test chainByteCount<<odd
	ifso chainCountWord=chainCountWord rshift 8
	ifnot if chainByteCount ls chainByteCountMax then [
		@chainCountPointer=chainCountWord
		chainCountPointer=chainCountPointer+1
		]
	]putCount



//**************************************************************
// getting code bytes
//**************************************************************


and nextPointCode() = valof [nextPointCode
	//returns:	0	end of decoding
	//				(i.e. end of chain encoding or end of bead)
	//		1-8	one of the 8 surrounding points:
	//				7 8 1
	//				6 * 2
	//				5 4 3
	[
	if chainCount eq 0 then [
		if chainByteCount eq chainByteCountMax resultis 0
		octant=chainCountWord<<GETCHAIN.octant
		chainCount=chainCountWord<<GETCHAIN.count+1
		chainByteCount=chainByteCount+1
		test chainByteCount<<odd
		ifso  chainCountWord=chainCountWord rshift 8
		ifnot [
			chainCountPointer=chainCountPointer+1
			chainCountWord=@chainCountPointer
			]
		]
	let nextBit=chainWord & 1
	chainCount=chainCount-1
	test chainBitPointer eq 0
	ifso [
		chainWordPointer=chainWordPointer+1
		chainWord=@chainWordPointer
		chainBitPointer=firstBit
		]
	ifnot [
		chainBitPointer=chainBitPointer-1
		chainWord=chainWord rshift 1
		]
	switchon nextBit into [
		case 0: resultis selecton octant into [
			case 0: 2; case 1: 8; case 2: 8; case 3: 6;
			case 4: 6; case 5: 4; case 6: 4; case 7: 2
			]
		case 1: resultis selecton octant into [
			case 0: 1; case 1: 1; case 2: 7; case 3: 7;
			case 4: 5; case 5: 5; case 6: 3; case 7: 3
			]
		]
	 ] repeat
	]nextPointCode
          

//*****************************************************************
// point draw/erase procedures
//*****************************************************************


and initEraseDraw(splinePointer, mode; numargs n) be [initEraseDraw
	if n eq 1 then mode=drawMode
	dashMode=splinePointer>>SPLINE.dashed
	if dashMode then [
		dashCount=dashOn
		dashDraw=true
		]
	let brushPt=splinePointer>>SPLINE.drawBrush + brushFont
	initBitBlt(brushPt + brushPt!0, mode)
	]initEraseDraw


and initBitBlt(brushPointer, mode) be [
	if curveBBC eq 0 then [
		curveBBC= obtainBlock(lBBC+1)
		// even address !
		if (curveBBC & 1) ne 0 then curveBBC=curveBBC+1
		Zero(curveBBC, lBBC)
		curveBBC>>BBC.SBMR=1
		curveBBC>>BBC.DBCA=bitmap+4
		curveBBC>>BBC.DBMR=scanlineWidth
		curveBBC>>BBC.gray↑0=#125252
		curveBBC>>BBC.gray↑1=#52525
		curveBBC>>BBC.gray↑2=#125252
		curveBBC>>BBC.gray↑3=#52525
		]
	initBitBlt=doInitBitBlt
	doInitBitBlt(brushPointer, mode)
	]


and doInitBitBlt(brushPointer, mode) be [
	let bh=(brushPointer!1) & #377
	curveBBC>>BBC.SBCA=brushPointer - bh
	curveBBC>>BBC.BH=bh
	curveBBC>>BBC.function=mode
	]


and resetEraseDraw() be [resetEraseDraw
	dashMode=0
	]resetEraseDraw


and draw(x, y) be [draw
	if dashMode then [
		test dashCount
		ifso dashCount=dashCount-1
		ifnot [
			dashDraw=not dashDraw
			dashCount=dashDraw ? dashOn, dashOff
			]
		unless dashDraw return
		]
	let bh=curveBBC>>BBC.BH
	x=x-3
	y=y+bh/2
	if ((x+8) le 0) % (x gr Xmax)
	 % (y ls 0) % (y ge (Ymax+bh)) return
	test x ls 0
	ifso [
		curveBBC>>BBC.DLX= 0
		curveBBC>>BBC.DW= x+8
		curveBBC>>BBC.SLX= -x
		]
	ifnot [
		curveBBC>>BBC.DLX= x
		curveBBC>>BBC.DW= ((x gr (Xmax-8)) ? (Xmax-x+1), 8)
		curveBBC>>BBC.SLX= 0
		]
	test y gr Ymax
	ifso [
		curveBBC>>BBC.DTY= 0
		curveBBC>>BBC.STY= y-Ymax
		curveBBC>>BBC.DH= bh+Ymax-y
		]
	ifnot [
		curveBBC>>BBC.DTY= Ymax-y
		curveBBC>>BBC.STY= 0
		curveBBC>>BBC.DH= (y ls bh) ? y+1, bh
		]
	BitBlt(curveBBC)
	]draw


and erase(x, y) be [
	// for historical reasons (compatibility)
	erase=draw
	draw(x, y)
	]


and eraseOrDraw(x, y) be [
	// for historical reasons (compatibility)
	eraseOrDraw=draw
	draw(x, y)
	]


and BitBlt(bbc) be [
	BitBlt= table [
		#055001;		// sta 3,1,2
		#145000;		// mov 2,1
		#111000;		// mov 0,2
		#045001;		// sta 1,1,2
		#126400;		// sub 1,1
		#061024;		// BitBlt
		#031001;		// lda 2,1,2
		#035001;		// lda 3,1,2
		#001401;		//  jmp 1,3
		]
	BitBlt(bbc)
	]



//*****************************************************************
// curve draw/erase procedure
//*****************************************************************


and curve(splinePointer, mode) be [curve
	// draw/erase the spline curve
	initChain(splinePointer)
	initEraseDraw(splinePointer, mode)

	let x=splinePointer>>SPLINE.xStart
	let y=splinePointer>>SPLINE.yStart
	switchon splinePointer>>SPLINE.type into [
	case regSpline:
		[ eraseOrDraw(x, y)
		  switchon nextPointCode() into [
			case 0: break
			case 1: y=y+1
			case 2: x=x+1; endcase
			case 3: x=x+1
			case 4: y=y-1; endcase
			case 5: y=y-1
			case 6: x=x-1; endcase
			case 7: x=x-1
			case 8: y=y+1; endcase
			]
		  ] repeat
		endcase
	case dotSpline:
		eraseOrDraw(x, y)
		endcase
	case horSpline:
		[
		let x1=splinePointer>>SPLINE.left
		let x2=splinePointer>>SPLINE.right
		for z=x1 to x2 do eraseOrDraw(z, y)
		endcase
		]
	case verSpline:
		[
		let y1=splinePointer>>SPLINE.bottom
		let y2=splinePointer>>SPLINE.top
		for z=y1 to y2 do eraseOrDraw(x, z)
		endcase
		]
	]
	resetEraseDraw()
	]curve


//*****************************************************************
// bead decoding
//*****************************************************************


and beadHit(splinePointer, b, x, y, x0, y0, h) = valof [beadHit
	initChain(splinePointer, b, b)
	compileif beadFlag then [ initEraseDraw(splinePointer, eraseMode) ]
	let dmin=500
	[ let d= ((x0 gr x) ? (x0-x), (x-x0)) +
		((y0 gr y) ? (y0-y), (y-y0))
	  compileif beadFlag then [ erase(x, y) ]
	  if d ls dmin then [ dmin=d; h>>HITPOINT.x=x; h>>HITPOINT.y=y ]
	  switchon nextPointCode() into [
		case 0: resultis dmin
		case 1: y=y+1
		case 2: x=x+1; endcase
		case 3: x=x+1
		case 4: y=y-1; endcase
		case 5: y=y-1
		case 6: x=x-1; endcase
		case 7: x=x-1
		case 8: y=y+1; endcase
		]
	  ] repeat
	compileif beadFlag then [ resetEraseDraw() ]
	]beadHit



and showBeads(splinePointer, mode) be [showBeads
compileif beadFlag then [
	if splinePointer>>SPLINE.type ne regSpline return
	initBitBlt(brushFont+rDotFont+3, mode)
	let x=splinePointer>>SPLINE.xStart
	let y=splinePointer>>SPLINE.yStart
	let nBeads=splinePointer>>SPLINE.nBeads
	let beadPointer=splinePointer>>SPLINE.chain+nBeads*BEADsize
	for i=1 to nBeads do [
		test beadPointer>>BEADXY.xDir
		ifso x=x+beadPointer>>BEADXY.deltaX
		ifnot x=x-beadPointer>>BEADXY.deltaX
		test beadPointer>>BEADXY.yDir
		ifso y=y+beadPointer>>BEADXY.deltaY
		ifnot y=y-beadPointer>>BEADXY.deltaY
		draw(x, y)
		beadPointer=beadPointer+2
		]
	]
	]showBeads

 

//*****************************************************************
// Spline operations: delete /  draw
//*****************************************************************

and checkSplineID(id) = ((id ls 1) % (id gr maxSplineID)) ? 0, splineTable!id


and eraseSpline(id) be [eraseSpline
	let splinePointer=checkSplineID(id)
	unless splinePointer return
	showSelect(splinePointer)
	splineColorSymbol(splinePointer)
	curve(splinePointer, eraseMode)
	compileif beadFlag then [ showBeads(splinePointer, eraseMode) ]
	]eraseSpline



and drawSpline(id) be [drawSpline
	let splinePointer=checkSplineID(id)
	unless splinePointer return
	curve(splinePointer, drawMode)
	showSelect(splinePointer)
	splineColorSymbol(splinePointer)
	compileif beadFlag then [ showBeads(splinePointer, drawMode) ]
	]drawSpline



//*****************************************************************
// selection marker
//*****************************************************************


and markSpline(id, b) be [markSpline
	let splinePointer=checkSplineID(id)
	unless splinePointer return
	splinePointer>>SPLINE.selected=b
	splineSelectSymbol(splinePointer)
	]markSpline



and showSelect(splinePointer) be [showSelect
	if splinePointer>>SPLINE.selected then
		splineSelectSymbol(splinePointer)
	]showSelect



and splineSelectSymbol(splinePointer) be [splineSelectSymbol
	let x0=splinePointer>>SPLINE.xSelect
	let y0=splinePointer>>SPLINE.ySelect
	let xr, xl=x0+4, x0-4
	let yt, yb=y0+4, y0-4
	for x=xl+1 to xr do XORdot(x, yt)
	for y=yb to yt-1 do XORdot(xr, y)
	for x=xl to xr-1 do XORdot(x, yb)
	for y=yb+1 to yt do XORdot(xl, y)
	]splineSelectSymbol


and splineColorSymbol(splinePointer) be [splineColorSymbol
	let splineColor=splinePointer>>SPLINE.color
	unless colorOn & (splineColor ne black) return
	XORcolorSymbol(splinePointer>>SPLINE.xColor,
			splinePointer>>SPLINE.yColor,
			splineColor)
	]splineColorSymbol


and XORcolorSymbol(x, y, thisColor) be [XORcolorSymbol
	let symbol=colorSymbol(thisColor)
	for i=0 to 15 do [
		let w=symbol!i
		for j=0 to 15 do [
			if (w & #100000) ne 0 then XORdot(x+j, y-i)
			w=w lshift 1
			]
		]
	]XORcolorSymbol



and XORdot(x, y) be [XORdot
	if (x le 0) % (y le 0) % (x ge Xmax) % (y ge Ymax) return
	let w=bitmap00 + (x rshift 4) - y*scanlineWidth
	@w=(@w) xor (#100000 rshift ( x & #17))
	]XORdot



and giveMeXY(splinePointer, lvX, lvY) be [giveMeXY
	switchon splinePointer>>SPLINE.type into [
		case regSpline: [
			let nKnots=splinePointer>>SPLINE.nKnots
			let thisKnot=splinePointer+SPLINEknotBase+2*(nKnots/2)
			@lvX=FTR(FLD(0, thisKnot))
			@lvY=FTR(FLD(0, thisKnot+2*nKnots))
			endcase
			]
		case dotSpline:
			@lvX=splinePointer>>SPLINE.left
			@lvY=splinePointer>>SPLINE.top
			endcase
		case horSpline:
		case verSpline:
			@lvX=(splinePointer>>SPLINE.left+splinePointer>>SPLINE.right)/2
			@lvY=(splinePointer>>SPLINE.top+splinePointer>>SPLINE.bottom)/2
			endcase
		]
	]giveMeXY