// CHATDIS.BCPL - Bob Sproull - Display protocol processing for CHAT.
// Copyright Xerox Corporation 1979
// modified: April 13, 1979  7:01 PM (E. Taft)

get "Chat.d"
get "ChatDis.d"
get "Streams.d"
get "AltoDefs.d"

//outgoing procedures
external [

	DisTypeIn
	DisTypeOut
	DisDisplay
	DisEvent

	DisReadFont
	GetsWord
	DisReset
	DisClose
	DisWs
	]

//incoming procedures
external [

//CHAT
	AwaitDisplayConnection
	Sti
	SendMarkData
	BigStack
	SmallStack
	CheckShiftSwat
	SendScreenParams
	EnqueueAudioOut

//OS
	MyFrame
	GotoLabel
	OpenFile
	Resets
	FileLength
	ReadBlock
	Allocate
	Free
	Gets
	Puts
	Closes
	SetBlock
	Zero
	MoveBlock
	Endofs
	CallSwat

//CONTEXT
	CallContextList
	InitializeContext
	Block

//QUEUE
	Unqueue
	Enqueue

//TIMER
	SetTimer
	TimerHasExpired

//BSP
	BSPGetMark
	CloseBSPSocket
	OpenLevel1Socket
	SetAllocation
	OpenRTPSocket
	CreateBSPStream
	BSPForceOutput
	ReleasePBI

//CHATDISOPS
	ShowChar
	ClipRegion
	BitBlt
	Backup
	ClipAndDrawLine
	FixGray
	CaretControl

//CHATDISCURVE
	CurveSetup
	DrawCurve

//DCBPRESS
	DCBPress
	]

//outgoing statics
external [
	DisplayVersion		//For printing at init time
	SS			//State vector for display stuff

	disTypeInCtx		//Pointers to contexts
	disTypeOutCtx
	disDisplayCtx
	disEventCtx

	caretTime		//Time at which to switch
	caretOn			//True if caret pattern is on
	]

static [
	DisplayVersion=15
	SS

	disTypeInCtx
	disTypeOutCtx
	disDisplayCtx
	disEventCtx

	caretTime
	caretOn
	]

//incoming statics
external [
	keys

	Parm
	Running
	ChatZone
	ScreenBuffer
	ScreenBufferLength
	YMax
	makeBootFile

	ctxQ
	TTYSoc; TTYStr
	DISSoc; DISStr
	staticErrCode
	DisErrStack
	DisErr
	ConnectionOpen
	DisMarkCount
	]

//internal statics
static [
	staticErrCode
	DisErrStack
	DisErr

	ConnectionOpen		//True if display connection is open
	DisMarkCount		//Count of marks for Dis TTY connection

	ShovelCount		//Number of bytes to shovel from display
	ShovelVector		// process to event process!
	ShovelOpByte = -1	//Op byte to output first if ne -1
	OldBut			//State of buttons last time

	TTYSyncPoint=-1		//Number of sync TTY awaiting (or -1)
	timingMarks = 0
	]

manifest
   [
   RTC=#430		//Real time clock
   ]

structure Bytes[
	Bytes↑1,1000 byte
	]

//The TTY connections:

let DisTypeIn() be
[
	let s=lv Parm>>PARM.InitialString
	for i=1 to s>>STR.length do Puts(TTYStr, s>>STR.char↑i)
	SendScreenParams(TTYSoc)
	[
	if Endofs(keys) then BSPForceOutput(TTYSoc)

	while Endofs(keys) do Block()
	let c=Gets(keys)
	if c eq -1 then
		[
		while timingMarks gr 0 do
			[
			SendMarkData(TTYSoc, MarkTimingReply)
			timingMarks = timingMarks -1
			]
		loop
		]
	Puts(TTYStr, c)

//If it's the first of the "eventtypechars", type the second one
	let ev=SS>>DISV.EventTypeChars rshift 8
	if c eq ev then
		[
		let nc=(SS>>DISV.EventTypeChars) & #377
		if nc then Puts(TTYStr, nc)
		]

	if SS>>DISV.Blocked ne 0 & c ne ev then
		[
		ShovelByteToNET(DBlocked)
		ShovelToNet(nil, 0)		//Flush buffer (RFS 10/4/78)
		SS>>DISV.Blocked=false
		]
	] repeat
]

and DisTypeOut() be
[
	let c=Gets(TTYStr)
	test c ge 0 then
		[
		if DisMarkCount gr 0 then loop
// If a sync point is received, record its number in TTYSyncPoint,
// and wait for display process to acknowledge goahead by
// setting TTYSyncPoint=-1.
		if c eq SS>>DISV.EscapeChar then
			[
			SyncAwait(-1)		//Be sure it's finished processing
			TTYSyncPoint=Gets(TTYStr)		//Sync number
			SyncAwait(-1)
			loop
			]
		ShowChar(SS>>DISV.TTYRegion, c)
		]
	or test c eq -1 then
		[
		let mb=BSPGetMark(TTYSoc)
		if mb eq MarkSync then DisMarkCount=DisMarkCount-1
		if mb eq MarkTiming then
			[ timingMarks = timingMarks+1; Sti(-1) ]
		]
	or if c eq -3 then finish		//Bad connection
] repeat

// Wait for TTYSyncPoint to equal prescribed value.  Times out
// after 20 seconds, and sets proper value.

and SyncAwait(val) be
[
	let tim=@RTC
	while (@RTC-tim) ls 20*27 & TTYSyncPoint ne val do Block()
	TTYSyncPoint=val
]

and DisClose() be
[DC
// Following close does not have a long timeout for DISSoc.  The reason is that
// a close requires active intervention by the Tenex job on the other end.
// Because the close is being initiated from the terminal, the chances
// of getting the intervention are small.
   while Running ne 2 do Block()

   Closes(TTYStr)
   if DISStr then
	[
	DISStr=0
	CloseBSPSocket(DISSoc, 200)
	]
   Running=0
   Block() repeat
]DC

//The Alto to Net process:

and DisEvent() be
[EV
Block()

unless ConnectionOpen then AwaitDisplayConnection()

//First, check buttons:
UpdateEventState()

// Caret processing
let caretFlip=(@RTC-caretTime) gr 0
test caretOn then
   [ if caretFlip then CaretControl(0) ] or
   [ if SS>>DISV.CaretRegion ne 0 &
		(caretTime eq 0 % caretFlip) then CaretControl(1)
   ]

let but=SS>>DISV.Buttons
if but ne OldBut then
   [BU
   let ChngBut=but xor OldBut
   let cmask=#100200; let sendit=false
   for n=0 to 7 do
	[
	if (ChngBut&cmask) ne 0 then
	   [
	   let enableBit=(((cmask&but) ne 0)? #177400,#377)&cmask
	   sendit=sendit%(enableBit&SS>>DISV.EnableEvents)
	   if (enableBit&SS>>DISV.EnableTimerStop) ne 0 then
		[
		SS>>DISV.TimerGoing=false
		]
	   if (enableBit&SS>>DISV.EnableTimerStart) ne 0 then
		[
		SS>>DISV.TimerGoing=true; SS>>DISV.TimerComplete=@RTC+SS>>DISV.TimerInterval
		]
	   ]
	cmask=cmask rshift 1
	]
   OldBut=but
   if sendit then
	[
	let dt=@RTC-SS>>DISV.LastEventTime
	if dt gr 255 then dt=255
	SS>>DISV.ElapsedTime=dt
	SS>>DISV.LastEventTime=@RTC
	SS>>DISV.ChangedButtons=ChngBut
	DisSend(lv SS>>DISV.Event, 9, true)
	AnnounceEvent()
	]
   ]BU

if SS>>DISV.TimerGoing ne 0 & (@RTC-SS>>DISV.TimerComplete) ge 0 then
	[
	SS>>DISV.TimerGoing=false
	let v=DTimeout*256
	DisSend(lv v, 1, true)
	AnnounceEvent()
	]

if ShovelCount ge 0 then
	[
	if ShovelOpByte ne -1 then Puts(DISStr, ShovelOpByte)
	ShovelOpByte = -1
	DisSend(ShovelVector, ShovelCount, ShovelCount eq 0)
	ShovelCount=-1
	]

]EV repeat

//DisSend(vector,bytecount,flush)
// Send some bytes to the other party.

and DisSend(v,bytes,flush) be
[DS
   for i=1 to bytes do Puts(DISStr, v>>Bytes.Bytes↑i)
   if flush then BSPForceOutput(DISSoc)
]DS

//UpdateEventState() reads state from various place in the Alto
// and stores it in the state vector, so that event machinery can
// find it.

and UpdateEventState() be
[UES
   SS>>DISV.Buttons=(not (@#177030))
   SS>>DISV.CursorX=@#426+SS>>DISV.CursorDX	//Cursor X
   SS>>DISV.CursorY=@#427+SS>>DISV.CursorDY	//Cursor Y
   // Get other buttons
   let t=@#177036
   let oth=#177420%(@#177037&#214)%(@#177035&#3)%(t&#100)
   if (t&#4000) ne 0 then oth=oth%#40
   SS>>DISV.OtherButtons=(not oth)
]UES

// Announce an event: perhaps send a EventTypeChars character,
// and clear the "blocked" flag, so typein will not generate another
// event

and AnnounceEvent() be
[An
   let ev=SS>>DISV.EventTypeChars
	if ev then Sti(ev rshift 8)
	SS>>DISV.Blocked=false
]An

// Net to Display process

and DisDisplay() be
[DS
   let ComB=nil
//ComTab!command = number of bytes of arguments
   let ComTab= ( table [ 0; 3; 3; 1; 3; 1; 0; 0;
			0; 0; 0; 5; 20; 12; 6; 40;
			0; 0; 40; 2; 1; 0; 2; 3;
			30; 4 ] ) -#200

   DisErrStack=MyFrame()
   DisErr=lDisErr

   Block() repeatuntil ConnectionOpen

[BL
// Check for exceptional condition
	if ConnectionOpen eq 0 then break		//Out to DS block

	ComB=Gets(DISStr)				//Get a byte 

//See if it is simply a character
	if ComB ls #200 then
		[
		ShowChar(SS>>DISV.CurrentRegion, ComB)
		loop
		]

//Or a special operation -- deposit in memory
	if ComB eq DDepositM then
		[
		let addr=GetsWord(DISStr)
		let count=Gets(DISStr)
		for i=0 to count-1 do
			addr!i=GetsWord(DISStr)
		loop
		]

//Check for illegal command code
	if ComB gr DLargest then
		[
		CallSwat("Illegal display protocol")
		loop
		]

//Gather arguments and dispatch
		[
		for i=1 to ComTab!ComB do
			(lv (SS>>DISV.argWord↑1))>>Bytes.Bytes↑i=Gets(DISStr)
		ComInterp(ComB)
		loop
		]

lDisErr:
	[ER
	if staticErrCode eq -1 then [ BSPGetMark(DISSoc) ]		//Mark
	if staticErrCode eq -3 then [ ConnectionOpen=false; break ]	//Out to DS block
	loop
	]ER

]BL repeat
]DS repeat

//Interpret a protocol command.  "op" is the op-code.  Arguments are
// carefully recorded in the args table (as WORDS, not bytes)

and ComInterp(op) be
[
let r=SS>>DISV.CurrentRegion
switchon op into
[CI
case DSync:		ShovelByteToNET(DSync)		//Fall through!

case DFlushInput:	ShovelToNet(nil, 0)		//Forces output
			endcase

case DClose:		ConnectionOpen=false		//Will happen!
			endcase

case DReset:		DisReset()			//Re-build display
			endcase

case DInvalidate:	[
			r>>REG.BBCValid=false
			endcase
			]

case DExamineR:
case DExamineV:		[
			let addr=SS>>DISV.argByte↑1
			addr=addr+((op eq DExamineR)? r, SS)
			compileif DExaminedR ne DExamineR %
				DExaminedV ne DExamineV then [ foo=nil ]
			ShovelOpAndVecToNet(op, addr, 2)
			endcase
			]

case DExamineM:		[
			let addr=SS>>DISV.argWord↑1
			let count=SS>>DISV.argByte↑3
			ShovelOpAndVecToNet(DExaminedM, addr, count*2)
			endcase;
			]

case DDepositR:
case DDepositV:		[
			let addr=SS>>DISV.argByte↑3
			addr=addr+((op eq DDepositR)? SS>>DISV.CurrentRegion, SS)
			@addr=SS>>DISV.argWord↑1
			endcase
			]

case DPress:		[
			BigStack()
			DCBPress(lv (SS>>DISV.argWord↑1), @#420)
			SmallStack()
			endcase
			]

case DLineTo:		[
			let x=SS>>DISV.argWord↑1
			let y=SS>>DISV.argWord↑2
			let wid=SS>>DISV.argByte↑5
			if wid ge #200 then wid=wid+#177400
			ClipAndDrawLine(r, r>>REG.CurX, r>>REG.CurY, x, y, wid)
			r>>REG.CurX=x
			r>>REG.CurY=y
			r>>REG.BBCValid=false
			endcase
			]

case DRegionR:		[
			r>>REG.SLX=SS>>DISV.argWord↑6
			r>>REG.STY=SS>>DISV.argWord↑7
			RegionOp(SS>>DISV.argWord↑10)
			endcase
			]

case DRegionC:		[
			r>>REG.STY=0
			RegionOp(SS>>DISV.argWord↑6)
			endcase
			]

case DCursorNudge:	[
			let dx=SS>>DISV.argWord↑1
			let dy=SS>>DISV.argWord↑2
			let saveit=SS>>DISV.argByte↑5
			let odx,ody=0,0
			if saveit then
				[
				odx,ody=SS>>DISV.CursorDX,SS>>DISV.CursorDY
				SS>>DISV.CursorDX=dx
				SS>>DISV.CursorDY=dy
				]
			@#424=@#424+odx-dx
			@#425=@#425+ody-dy
			endcase
			]

case DReadState:	[
			let v=vec 5
			MoveBlock(v, lv SS>>DISV.Event, 5)
			v>>Bytes.Bytes↑1=DState
			ShovelToNet(v, 9)
			endcase
			]

case DCaretOff:		[
			CaretControl(0)
			endcase
			]

case DReadFont:		[
			BigStack()
			let n=SS>>DISV.argWord↑1
			let a=(lv SS>>DISV.fonts)!n
			if (a&#177776) ne 0 then Free(ChatZone, a)
			DisReadFont(n, lv (SS>>DISV.argWord↑2), 0)
			SmallStack()
			endcase
			]

case DStartTimer:	[
			SS>>DISV.TimerGoing=true
			SS>>DISV.TimerComplete=@RTC+SS>>DISV.argWord↑1
			endcase
			]

case DBackup:			[
			CaretControl(0)
			Backup(r, SS>>DISV.argWord↑1)
			endcase
			]

case DSyncBefore:	[
			SyncAwait(SS>>DISV.argByte↑1)	//Wait for TTY to get here
			endcase
			]

case DSyncAfter:	[
			TTYSyncPoint=-1
			Block()				//Allow TTY in right away.
			endcase
			]

case DCurveSetup:	[
			let drawMode=SS>>DISV.argByte↑1
			let brushShape=SS>>DISV.argByte↑2
			let brushWidth=SS>>DISV.argByte↑3
			CurveSetup(r, drawMode, brushShape, brushWidth)
			endcase
			]

case DCurveTo:		[
			let x1=SS>>DISV.argWord↑1
			let y1=SS>>DISV.argWord↑2
			let dxyVec=vec 12
			MoveBlock(dxyVec, lv (SS>>DISV.argWord↑3), 12)
			let n=SS>>DISV.argWord↑15
			DrawCurve(r>>REG.CurX, r>>REG.CurY, x1, y1,
				dxyVec, dxyVec+2, dxyVec+4, dxyVec+6, dxyVec+8, dxyVec+10, n)
			r>>REG.CurX=x1
			r>>REG.CurY=y1
			endcase
			]

case DAudioOut:		[
			EnqueueAudioOut(SS>>DISV.argWord↑1, SS>>DISV.argWord↑2)
			endcase
			]

]CI
]

and ShovelToNet(v, count) be
[SS
	ShovelVector=v
	ShovelCount=count
	while ShovelCount ne -1 do Block()
]SS

and ShovelByteToNET(b) be
[SB
	b=b lshift 8
	ShovelToNet(lv b, 1)
]SB

and ShovelOpAndVecToNet(op, v, count) be
[
	ShovelOpByte = op
	ShovelToNet(v, count)
]

and GetsWord(str) = valof
[GSW
let b=Gets(str) lshift 8
resultis (b+Gets(str))
]GSW

//DisReset() -- called to reset the display properly.

and DisReset() be
[DR
   Zero(ScreenBuffer, ScreenBufferLength)
   let dcb=ScreenBuffer+ScreenBufferLength-lDCB
	dcb!1=disWidth
	dcb!2=ScreenBuffer
	dcb!3=(YMax+1)/2
   @#420=dcb

   Zero(SS+zeroDISVFirst, zeroDISVLength)
   let p=lv SS>>DISV.regions
   SS>>DISV.TTYRegion=p				//TTY region = 0
   SS>>DISV.CurrentRegion=p+lREG		//DIS region = 1
   for i=0 to Parm>>PARM.nRegions-1 do
	SetRegionDefault(p+i*lREG, i eq 0)

   SS>>DISV.Event=DEvent
]DR

//SetRegionDefault(r, scroll) -- sets up all defaults in a region
// sets BBCValid=false

and SetRegionDefault(r, scroll) be
[SRD
   Zero(r, size REG/16)
   let f=(lv SS>>DISV.fonts)!0
   if f eq 0 then CallSwat("No default font")		//No default font!
   r>>REG.Font=f
   let h=f>>STRIK.ascent+f>>STRIK.descent
   r>>REG.CurY=h*2
   r>>REG.CurX=10
   r>>REG.CrX=10
   r>>REG.LfY=h
   r>>REG.Right=XMax
   r>>REG.Bottom=YMax
   r>>REG.Scroll=scroll
   r>>REG.BBCOp=BBCPaint+BBSBitMap

   r>>REG.DBCA=ScreenBuffer
   r>>REG.DBMR=disWidth
]SRD

//RegionOp(gray) -- common code for both kinds of region ops

and RegionOp(gray) be
[RO
   let r=SS>>DISV.CurrentRegion
   MoveBlock(lv r>>REG.DLX, lv (SS>>DISV.argWord↑2), 4)
   let f=SS>>DISV.argWord↑1
   r>>REG.Function=f
   r>>REG.SBCA=ScreenBuffer
   r>>REG.SBMR=disWidth

   if ClipRegion(r) then
   [
   if (f&8) ne 0 then FixGray(r, gray)	//Only do this if gray region used
   BitBlt(r)
   ]
   r>>REG.BBCValid=false
]RO


// Font reading routine.
// DisReadFont(fontNumber, name, fp) returns
//		0 => cannot find file
//		1 => cannot allocate storage
//		otherwise all is well.

and DisReadFont(fontNumber, nam, fp) = valof 
[
	compileif size STRIK-size STRIKE ne 16 then [ foo=nil ]

let fa = valof
	[
	let fs=OpenFile(nam, ksTypeReadOnly, 0, 0, fp)
	if fs eq 0 then resultis 0		//Non-ex font
	let wl=FileLength(fs)/2
	let a=Allocate(ChatZone, wl+1, -1)
	if a eq 0 then resultis 1	//No room for it
	Resets(fs)
	ReadBlock(fs, a+1, wl)
	Closes(fs)
	let bm=lv a>>STRIK.bitmap
	a>>STRIK.xPosTable=bm+(a>>STRIK.raster)*
			(a>>STRIK.ascent+a>>STRIK.descent)
	a>>STRIK.max=a>>STRIK.max-a>>STRIK.min	//Max tested after subtract
	resultis a
	]

	(lv SS>>DISV.fonts)!fontNumber=fa
	resultis fa
]

and DisWs(str) be
[
   if ConnectionOpen then return	//No interference
   for i=1 to str>>STR.length do
		ShowChar(SS>>DISV.TTYRegion, str>>STR.char↑i)
]