//CHATDISOPS -  Bob Sproull  - Display operations for Display Protocol.
// Copyright Xerox Corporation 1979
//Routines to draw things on the screen.
// modified: November 22, 1978  2:39 PM (E. Taft)

get "Chat.d"
get "ChatDis.d"

//outgoing procedures
external [
	ClipAndDrawLine
	DrawLine
	ShowChar
	Backup
	ClipRegion
	ClipRegionBlt
	FixGray
	CaretControl
	]

//incoming procedures
external [
	BitBlt
	Zero
	SetBlock
	MoveBlock
	Block
	]

//incoming statics
external [
	ScreenBuffer
	YMax
	SS
	caretTime
	caretOn
	]

//File-wide definitions

manifest	MaskTab1 = #457	// location of system mask table
manifest RTC=#430

//ClipAndDrawLine(r,x,y,x1,y1,width)

let ClipAndDrawLine(r,x,y,x1,y1,width) be
[
// ClipCode(r, p) = code for point (p!0,p!1)
	if width eq 0 then width=1
	let widthOffset=(width ge 0 ? width, -width)-1

	let ClipCode(r, wOff, p)=
		(p!0 ls r>>REG.Left ? 1,0)+
		(p!0 gr (r>>REG.Right - wOff) ? 2,0)+
		(p!1 ls r>>REG.Top ? 4,0)+
		(p!1 gr (r>>REG.Bottom - wOff) ? 16,0)

	let p1=lv x
	let p2=lv x1
	let c1=nil
	let c2=ClipCode(r, widthOffset, p2)
   [
	c1=ClipCode(r, widthOffset, p1)
	if (c1&c2) ne 0 then return		//Cannot be seen
	if c1+c2 eq 0 then break		//Visible
	if c1 eq 0 then				//Exchange so p1 off screen
		[
		let t=c1; c1=c2; c2=t
		let t=p1; p1=p2; p2=t
		]

	let val=r>>REG.Left; let w=0
	test c1 ge 8 then			// y gr bottom
		[ val=r>>REG.Bottom - widthOffset; w=1] or
	test c1 ge 4 then			// y ls top
		[ val=r>>REG.Top; w=1] or
	if c1 ge 2 then				// x gr right
		[ val=r>>REG.Right - widthOffset; w=0]
						// x ls left

//	Endpoints are (p1!0,p1!1) and (p2!0,p2!1); modify p1 so that
//		p1!w=val
	let nw=1-w		//The "other" one
	let numerator1=val-p1!w
	let numerator2=p2!nw-p1!nw
	let denominator=p2!w-p1!w
// Note that numerator1 and denominator have same sign
	let sign=0
	if numerator1 ls 0 then
		[
		numerator1=-numerator1
		denominator=-denominator
		]
	if numerator2 ls 0 then [ numerator2=-numerator2; sign=-1 ]
// Now apply muldiv
	let amount=( table [
		#55001;	//sta 3,1,2
		#155000;	//mov 2,3
		#111000;	//mov 0 2
		#21403;	//lda 0 3 3
		#101220;	//movzr 0 0
		#61020;	//mul
		#31403;	//lda 2 3 3
		#61021;	//div
		#101010;	// mov# 0 0
		#121000;	//mov 1 0
		#171000;	//mov 3 2
		#35001;	//lda 3 1 2
		#1401;	//jmp 1,3
				] ) (numerator1,numerator2,denominator)
	p1!nw=p1!nw+(sign? -amount,amount)
	p1!w=val
   ] repeat

	DrawLine(x,y,x1,y1,ScreenBuffer,disWidth,width)
]

//DrawLine(x,y,x1,y1,BitMap,WordWidth[,width])
//  Draws a line on the screen, from (x,y) to (x1,y1) INCLUSIVE.
//  Bear in mind that y is measured from the top of the screen!
//	  Width<0 means xor with memory

and DrawLine(x,y,x1,y1,BitMap,WordWidth,width; numargs na) be
[DL
	if na ls 7 then width = 1
	let dx,dy=x1-x,y1-y
	let x0,y0 = x,y
	let yinc=nil

	// Arrange things to make dx always positive
	if dx ls 0 then [ dx, dy = -dx, -dy; x0, y0 = x1, y1 ]
	test dy ge 0 then [ yinc=WordWidth ] or
			  [ dy=-dy; yinc=-WordWidth ]

for w=1 to (width ge 0? width,-width) do
  [
	let ybase = y0*WordWidth+BitMap
	let mapptr=(x0 rshift 4)+ybase
	let mask=(1+MaskTab1!((not x0)&#17))

test dx ge dy
then			//x is fastest mover.
	[
	let cdl=(dx rshift 1)
	for i=0 to dx do
	  [	//main loop
	  test width ge 0 then @mapptr=@mapptr % mask
			or @mapptr=@mapptr xor mask

	  cdl=cdl+dy
	  if cdl gr dx then [ cdl=cdl-dx; mapptr=mapptr+yinc ]
	  mask = mask rshift 1
	  if mask eq 0 then	// crossed a word boundary
	    [
	    mapptr = mapptr+1
	    mask = #100000
	    ]
	  ]
	y0=y0+1
	]
or			//y is fastest mover.
	[
	let cdl=(dy rshift 1)
	for i=0 to dy do
	  [
	  test width ge 0 then @mapptr=@mapptr % mask
			or @mapptr=@mapptr xor mask

	  cdl=cdl+dx
	  if cdl gr dy then [ cdl=cdl-dy
			mask = mask rshift 1
			if mask eq 0 then	// word boundary
			  [
			  mapptr = mapptr+1
			  mask = #100000
			  ]
			]
	  mapptr=mapptr+yinc
	  ]
	x0=x0+1
	]
  ]
]DL

//ShowChar(r, c) ... Display the character "c" in region "r"

and ShowChar(r, c) be
[SC
   if r eq SS>>DISV.CaretRegion then CaretControl(0)
   if c le #15 then
	[
	c=SpecialChar(r, c)
	if c ls 0 then return
	]
   let f=r>>REG.Font
   c=c-f>>STRIK.min
   if c ls 0 % c gr f>>STRIK.max then c=f>>STRIK.max+1	//Illegal char

   let xp=f>>STRIK.xPosTable
   let wid=xp!(c+1)-xp!c
   if wid eq 0 then			//Illegal char if of zero width
	[
	c=f>>STRIK.max+1
	wid=xp!(c+1)-xp!c
	]
   if r>>REG.Scroll eq -2 then AutoShove(r, wid)

   let cx=r>>REG.CurX
   let bold=0
   [
	r>>REG.SLX=xp!c
	r>>REG.DW=wid

	unless r>>REG.BBCValid then Validate(r)

	test r>>REG.Italic
	ifso ShowItalic(r, c)
	ifnot
	[
	let lvSimple=lv r>>REG.SimpleClip
	test @lvSimple then
	   [
	   test r>>REG.CurX ge r>>REG.Left & r>>REG.CurX+wid-1 le r>>REG.Right
		then BitBlt(r) or if ClipRegion(r, lvSimple) then BitBlt(r)
	   ] or if ClipRegion(r, lvSimple) then BitBlt(r)
	]

	if r>>REG.Bold eq 0 % bold ne 0 then break
	r>>REG.CurX=cx+1
	r>>REG.DLX=cx+1
	bold=1
   ] repeat

   cx=cx+wid
   r>>REG.CurX=cx
   r>>REG.DLX=cx
]SC

// Set up most of the BBC parameters for the region.

and Validate(r) be
[
	let f=r>>REG.Font
	r>>REG.DTY=r>>REG.CurY-f>>STRIK.ascent+1
	r>>REG.DLX=r>>REG.CurX
	r>>REG.DH=f>>STRIK.ascent+f>>STRIK.descent
	r>>REG.SBCA=lv f>>STRIK.bitmap
	r>>REG.SBMR=f>>STRIK.raster
	r>>REG.STY=0
	r>>REG.Function=r>>REG.BBCOp
	r>>REG.BBCValid=true
	r>>REG.SimpleClip=false
]

//SpecialChar(r, c)
// Returns -1 if nothing to do, else char to display

and SpecialChar(r, c) = valof
[
   if c eq #15 then
	[
	r>>REG.CurX=r>>REG.CrX		//Carriage return
	r>>REG.BBCValid=false
	resultis -1
	]
   if c eq #12 then
	[
	r>>REG.CurY=r>>REG.CurY+r>>REG.LfY
	r>>REG.BBCValid=false
	if r>>REG.Scroll then AutoScroll(r)
	resultis -1
	]
   if c eq #11 & r>>REG.Tab ne 0 then
	[
	let t=r>>REG.Tab
	r>>REG.CurX=((r>>REG.CurX-r>>REG.CrX)/t +1)*t+r>>REG.CrX
	r>>REG.BBCValid=false
	resultis -1
	]
   resultis c
]

//ShowItalic(r, c)
// BBC is all set up for the standard character.  Instead, show
// it italic...

and ShowItalic(r, c) be
[
	let sav=vec size BBC/16
	let h=r>>REG.DH
	r>>REG.DLX=r>>REG.DLX+h/4-1

	[
	r>>REG.DH=(h ls 4)? h,4
	MoveBlock(sav, lv r>>BBC.Function, size BBC/16)
	ClipRegionBlt(r)
	if h le 4 then break		//All done

	MoveBlock(lv r>>REG.Function, sav, size BBC/16)
	r>>REG.DLX=r>>REG.DLX-1
	r>>REG.DTY=r>>REG.DTY+4
	r>>REG.STY=r>>REG.STY+4
	h=h-4
	] repeat

	r>>REG.BBCValid=false
]

//ClipRegion(reg, lvSimple)
// Clips the BBC destination to correspond to LIMITS of the region.
// Also updates BBC source accordingly.
// Returns true if there is something to show.
// Sets @lvSimple if no part of the thing is off in Y

and ClipRegion(reg, lvSimple; numargs n) = valof
[
   if n eq 1 then lvSimple= lv n

   @lvSimple=false
   let t=reg>>REG.DTY			//Top of destination
   let b=t+reg>>REG.DH-1
   if b gr reg>>REG.Bottom then
	[
	let bottom=reg>>REG.Bottom
	if t gr bottom then resultis false
	reg>>REG.DH=reg>>REG.DH+bottom-b
	b=bottom
	reg>>REG.BBCValid=false
	]
   if t ls reg>>REG.Top then
	[
	let top=reg>>REG.Top
	if b ls top then resultis false
	let diff=t-top
	reg>>REG.DH=reg>>REG.DH+diff
	reg>>REG.STY=reg>>REG.STY-diff
	reg>>REG.DTY=top
	reg>>REG.BBCValid=false
	]
   @lvSimple=true
   let l=reg>>REG.DLX
   let r=l+reg>>REG.DW-1
   if r gr reg>>REG.Right then
	[
	let right=reg>>REG.Right
	if l gr right then resultis false
	reg>>REG.DW=reg>>REG.DW+right-r
	r=right
	reg>>REG.BBCValid=false
	]
   if l ls reg>>REG.Left then
	[
	let left=reg>>REG.Left
	if r ls left then resultis false
	let diff=l-left
	reg>>REG.DW=reg>>REG.DW+diff
	reg>>REG.SLX=reg>>REG.SLX-diff
	reg>>REG.DLX=left
	reg>>REG.BBCValid=false
	]
   resultis true
]

// ClipRegionBlt(r) -- if clip succeeds, blt.

and ClipRegionBlt(r) be if ClipRegion(r) then BitBlt(r)

//AutoScroll(r) -- scrolls a region that has just witnessed a LF.

and AutoScroll(r) be
[
   let f=r>>REG.Font
   let dy=r>>REG.LfY
//yDiv is the top scan line of the bottom region:
   let yDiv=r>>REG.CurY-dy+f>>STRIK.descent+1
   if yDiv le r>>REG.Top then return		//Nothing to do....

   SetHuge(r)
   r>>REG.Function=BBCReplace+BBSBitMap
   test r>>REG.Bottom+1-yDiv ge dy then		//Enuf room for a line?
	[				//Move bottom part down by dy
	r>>REG.DTY=yDiv+dy
	r>>REG.DH=YMax+1	//Make clip do the work
	r>>REG.STY=yDiv
	ClipRegionBlt(r)
	Clear(r, yDiv, dy)
	]
   or
	[				//Move whole region up by dy
	let top=r>>REG.Top
	r>>REG.DTY=top
	r>>REG.DH=yDiv-top-dy
	r>>REG.STY=top+dy
	ClipRegionBlt(r)
	Clear(r, yDiv-dy, dy)
	r>>REG.CurY=r>>REG.CurY-dy
	]
   r>>REG.BBCValid=false
// This operation is potentially very time-consuming, so give
// other guys a chance (Pup code especially)
   Block()
]

// Move current line of region to the right by amount x

and AutoShove(r, x) be
[
   MoveTextLine(r, r>>REG.CurX+x, r>>REG.CurX, x)
]

// Backup -- move current line of region to left by amount x

and Backup(r, dist) be
[
	let oldx=r>>REG.CurX
	let newx=oldx-dist
   let left=r>>REG.Right+1-dist
   if newx gr left then left=newx
   MoveTextLine(r, newx, left, dist)
   r>>REG.CurX=newx
]

// MoveTextLine(r, newx, fillx, filldx)
//  Moves (CurX to right limit) to destination newx
//  Then fills in (fillx to fillx+filldx-1) with background

and MoveTextLine(r, newx, fillx, filldx) be
[
// First, move existing part of line
   Validate(r)	// Set up DTY, DH, DLX.
   MoveBlock(lv r>>REG.SBCA, lv r>>REG.DBCA, 4)
   r>>REG.DLX=newx
   r>>REG.DW=XMax+1
   r>>REG.Function=BBCReplace+BBSBitMap
   ClipRegionBlt(r)
// Now, fill in opened up region with background
   r>>REG.DLX=fillx
   r>>REG.DW=filldx
   FixGray(r)
   r>>REG.Function=BBCReplace+BBSGray
   ClipRegionBlt(r)
   r>>REG.BBCValid=false
]

//Clear(region, top, height)

and Clear(r, top, height) be
[
   SetHuge(r)
   r>>REG.Function=BBCReplace+BBSGray
   r>>REG.DTY=top
   r>>REG.DH=height
   FixGray(r)
   ClipRegionBlt(r)
]

and SetHuge(r) be
[
   r>>REG.DLX=0
   r>>REG.DW=XMax+1
   r>>REG.SLX=0
   r>>REG.SBCA=ScreenBuffer
   r>>REG.SBMR=disWidth
]

and FixGray(r, gray; numargs na) be
[
	if na eq 1 then gray=r>>REG.ClearColor
	let gp=lv r>>REG.Gray
	test gray eq 0 then Zero(gp, 4) or
	test gray eq -1 then SetBlock(gp, -1, 4) or
	   [
	   let tg=vec 3		//Temporary
	   for i=0 to 3 do
		[
		let nib=gray&#17
		nib=nib+(nib*16)
		nib=nib+nib*256
		tg!(3-i)=nib
		gray=gray rshift 4
		]
	   let q=r>>REG.DTY+1
	   if r>>REG.DTY ls r>>REG.STY then
		[
		let t=tg!1; tg!1=tg!3; tg!3=t
		q=-1-q-r>>REG.DH
		]
	   for i=0 to 3 do gp!i=tg!((i+q)&3)
	   ]
]

// Caret control
// w=1 to turn it on, 0 to turn it off

and CaretControl(w) be
[
   if w eq caretOn then return
   caretOn=w

   let r=SS>>DISV.CaretRegion
   caretTime=@RTC+SS>>DISV.CaretRate
   if r eq 0 then caretTime=0

	compileif size BBC/16 ne 16 then [ foo=nil ]
	let savedB=((table [ 0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0 ] )+1)&(-2)

// Turning the caret on:
	test caretOn then
		[
		r>>REG.Function=BBCInvert
		r>>REG.DLX=r>>REG.CurX-SS>>DISV.CaretDX
		r>>REG.DTY=r>>REG.CurY-(15-SS>>DISV.CaretDY)
		r>>REG.DW=16
		r>>REG.DH=16
		r>>REG.SBCA=(lv SS>>DISV.CaretPattern)
		r>>REG.SBMR=1
		r>>REG.SLX=0
		r>>REG.STY=0
		test ClipRegion(r) then
			[
			MoveBlock(savedB, r, size BBC/16)
			BitBlt(r)
			] or caretOn=0
		r>>REG.BBCValid=false
		]
	or BitBlt(savedB)
]