//CHATTTY.BCPL - Bob Sproull - Pup User Telnet - BCPL
// Copyright Xerox Corporation 1979, 1980
// modified: October 19, 1980  4:02 PM (E. Taft)
// modified: July 8, 1983  1:28 PM (T. Diebert)

get "Chat.d"
get "ChatBSP.d"
get "AltoDefs.d"

//outgoing procedures
external [
	ChatTTY

	GetKey
	GetString
	ChatHandlePup
	DirectKeys
	SetScreenColor
	ScreenBlack
	ScreenWhite
	CaretOff
	FlipCaret
	]

//incoming procedures
external [
//CHAT
	BigStack
	SmallStack
	SendMarkData
	Sti
	CheckShiftSwat
	SendScreenParams
	BitBlt
	ChatReadParams
	ChatComOpen
	EnqueueAudioOut

//OS
	Gets
	Puts
	OpenFile
	Closes
	Resets
	Endofs
	Ws
	Wss
	ReadBlock
	FileLength
	FilePos
	SetFilePos
	CleanupDiskStream
	TruncateDiskStream

	CreateDisplayStream
	ShowDisplayStream
	CharWidth
	GetFont
	GetBitPos
	SetBitPos
	GetLmarg
	GetRmarg
	EraseBits

	Allocate
	Free
	Zero
	InitializeZone
	MyFrame
	ReturnFrom
	SysErr

//Pup
	BSPForceOutput
	BSPGetMark
	ReleasePBI
	Min

//QUEUE
	Enqueue
	Unqueue

//ALTOTIME
	SetTimer
	TimerHasExpired

//CONTEXT
	CallContextList
	InitializeContext
	Block

//ETHERBOOT
	EtherBoot
	]

//outgoing statics
external [
	TTYVersion
	caretDS; caretShown; timingMarks
	DIS; WasBlack
	]

static [
	TTYVersion=14
	]

//incoming statics
external [
	ChatZone			//Main free-storage zone
	Parm				//Chat parameter vector
	TTYSoc; TTYStr			//Socket, stream for TTY connection
	Running				// 0 = closed; 1 = open; >2 = please close
	ctxQ				//Running contexts
	ScreenBuffer			//Address of usable area for screen
	ScreenBufferLength		// .. length of same..
	makeBootFile

//OS
	keys
	dsp
	lvUserFinishProc
	]

//local statics
static [
	instream			//Current source of iput (0=> keyboard)
	SendTermType=true		//True if terminal characteristics s/b sent
	tyiCtx				//Type-In context
	tyoCtx				//Type-Out context
	WasBlack			//True if screen is flashed
	DIS				//Display stream to use
	MarkCount			//Number if "interrupts" received
	SystemScroll			//Normal scroll routine
	FontPointer			//Pointer to current font

	TStream				// Non-zero if typescript going
	TToGoTillWrap			//Count of TypeScript chars till wrap file
	tsToFlush			//Count of TypeScript chars till flush
	tsTimer				//Time until forced TS flush
	savedUFP
	caretDS
	caretShown = false
	pleaseFinish
	timingMarks = 0
	RwasCR = false
	TwasCR = false
	]


//Note: This code is run with entire OS around.  No Junta is done.

let ChatTTY() be
[
ScreenBuffer=ChatReadParams		//Bottom of usable area
ScreenBufferLength=23000
let zoneBot=ScreenBuffer+ScreenBufferLength
let zoneTop=MyFrame()-400		//Enough for ChatTTY
ChatZone=InitializeZone(zoneBot,zoneTop-zoneBot)
@#335=zoneTop
TypeScriptStart()
ScreenSetUp()

//Do the main thing:

tyiCtx=Allocate(ChatZone,200)
tyoCtx=Allocate(ChatZone,200)
let comCtx=Allocate(ChatZone,200)
savedUFP = @lvUserFinishProc
@lvUserFinishProc = TTYHandleFinish

	[
	DirectKeys(DIS)
	Enqueue(ctxQ, InitializeContext(tyiCtx, 200, TypeIn))
	Enqueue(ctxQ, InitializeContext(tyoCtx, 200, TypeOut))
	Enqueue(ctxQ, InitializeContext(comCtx, 200, Command))

// Set up the various kinds of error handling
	TTYStr>>ST.error=ChatHandleBSPError
	TTYSoc>>BSPSoc.bspOtherPupProc=ChatHandlePup

	Running=1			//Want to keep open
	while Running do
		[
		CallContextList(ctxQ!0)
		CheckShiftSwat()
		]

	if pleaseFinish then finish
	Unqueue(ctxQ, comCtx) // tyiCtx and tyoCtx were unqueued by Command()

	CaretOff()
	Wss(DIS, "*n*l~~~~~~~~ Connection terminated ~~~~~~~~*n*l")

	@(lv Parm>>PARM.ConnectString) = 0
	@(lv Parm>>PARM.InitialString) = 0
	ChatComOpen()
	SendTermType = true
	] repeat
]

//Type In (to Partner)
// This process handles all Alto => Partner traffic
// Sets up input stream (given DO file, etc.)
// Pre-loads output buffer with MAXC login sequence if any.
// Loops processing all traffic.

and TypeIn() =valof 
[TI
//Give out whatever initial string there is:
   let str=lv Parm>>PARM.InitialString
   for i=1 to str>>STR.length do Puts(TTYStr, str>>STR.char↑i)
   BSPForceOutput(TTYSoc)

[MainLoop
MainLp:

if Parm>>PARM.DoDirective gr 0 then
   [
   BigStack()
   instream=OpenFile(lv Parm>>PARM.DoFileName, ksTypeReadOnly, charItem)
   if instream eq 0 % Endofs(instream) then
	[
	Ws("*nFile does not exist.")
	instream=0
	Parm>>PARM.DoDirective=0
	]
   Parm>>PARM.DoDirective=-Parm>>PARM.DoDirective
   SmallStack()
   ]

if SendTermType then	//After attach or login,bitte
   [
   SendTermType=false
   SendScreenParams(TTYSoc)
   ]


//Get a character from prevailing input source:
let c=nil
test instream eq 0
ifso	[				//Read from keyboard
	c=GetKey(0)		//Get a char
	]
ifnot	[
	BigStack()
	test Endofs(instream) then
	   [
	   Closes(instream)	//End of auto file
	   instream=0
	   if Parm>>PARM.DoDirective eq -2 then Running=4
	   c=-1
	   ]
	or c=Gets(instream)

	c=SmallStack(c)
	]

//If it is negative, it was probably simulated input to cause us to loop:
if c ge 0 then
	[
	Puts(TTYStr, c)
	if Parm>>PARM.PCmode ne 0 & c eq #15 then Puts(TTYStr, #12) // Send LF with CR
	if Parm>>PARM.Echo then Puts(DIS, c)
	if TStream ne 0 & Parm>>PARM.tsTypeIn ne 0 then TypeScriptChars(c)
	]

if instream eq 0 & Endofs(keys) ne 0 then
	BSPForceOutput(TTYSoc)

]MainLoop repeat

]TI

// TypeOut -- this process handles all Partner => Alto traffic

and TypeOut() be
[TO
let inChar=Gets(TTYStr)		//Get a byte
if caretShown then CaretOff()
test inChar ge 0 then
	[
	if MarkCount gr 0 then loop
	if inChar eq 7 then [ ScreenBlack(); loop ]
	if WasBlack then ScreenWhite()
	if (inChar ne #12) & RwasCR & (Parm>>PARM.PCmode ne 0) then
		[
		Puts(DIS, #12)
		RwasCR = false
		if TStream ne 0 & Parm>>PARM.tsTypeOut ne 0 then
			TypeScriptChars(#12)
		]
	RwasCR = false
	if TStream ne 0 & Parm>>PARM.tsTypeOut ne 0 then
		TypeScriptChars(inChar)
	Puts(DIS,inChar)
	if inChar eq #15 then RwasCR = true
	]
or test inChar eq -1 then		//Mark
	[
	switchon BSPGetMark(TTYSoc) into
		[
		case MarkSync:
			MarkCount = MarkCount-1; endcase
		case MarkTiming:
			timingMarks = timingMarks+1; Sti(-1); endcase
		case MarkLineWidth: case MarkPageLength:
		case MarkTerminalType:
			Gets(TTYStr); endcase
		]
	]
or if inChar eq -3 then Running=3	//Bad connection -- close
]TO repeat 

// Command
// This process and associated routines handles all commands
// (explicit from keyboard; implicit from wanting to close connection
// by finishing, hitting EOF on a DO file, etc.)

// The state of the world is represented by the value of Running:
// 0 Closed
// 1 Open
// 2 Please close and permit user to establish another connection
// 3 Please close because of error or remote disconnect
// 4 Please close and finish

and Command() be
[
Block()
if @#177035 ne #177775 & Running eq 1 loop
if Running eq 1 then
	[
	DirectKeys(dsp)		//So keyboard typing will come here
	Ws("*nCommand: ")
	let c=GetKey()
	let OnOff(flag) be Ws(flag? "ON", "OFF")
	switchon c into
		[
		case $X: case $x:
			Parm>>PARM.LineFeeds=not Parm>>PARM.LineFeeds
			Ws("Line Feed Strip ")
			OnOff(not Parm>>PARM.LineFeeds)
			endcase
		case $E: case $e:
			Parm>>PARM.Echo=not Parm>>PARM.Echo
			Ws("Echo "); OnOff(Parm>>PARM.Echo)
			endcase
		case $C: case $c:
			Parm>>PARM.ControlChars=not Parm>>PARM.ControlChars
			Ws("Control chars "); OnOff(Parm>>PARM.ControlChars)
			endcase
		case $M: case $m:
			Parm>>PARM.PCmode=not Parm>>PARM.PCmode
			Ws("IBM-PC mode "); OnOff(Parm>>PARM.PCmode)
			RwasCR = false
			endcase
		case $Q: case $q:
			Ws("Quit!")
			Running=4
			endcase
		case $F: case $f:
			Ws("Font file name: ")
			GetString(lv Parm>>PARM.FontName)
			ScreenSetUp()
			endcase
		case $D: case $d:
			Ws("Do file name: ")
			GetString(lv Parm>>PARM.DoFileName)
			Parm>>PARM.DoDirective=1
			Sti(-2)		//Force receipt of char
			endcase
		case $S: case $s:
			Ws("Send file name: ")
			GetString(lv Parm>>PARM.DoFileName)
			Parm>>PARM.DoDirective=1
			Sti(-2)		//Force receipt of char
			endcase
		case $R: case $r:
			if makeBootFile then docase -1
			Ws("Receive file name (CR to close): ")
			GetString(lv Parm>>PARM.TSFileName)
			TypeScriptChars()
			Parm>>PARM.TypeScriptLength = -1
			TypeScriptStart()
			endcase
		case $T: case $t:
			if makeBootFile then docase -1
			Ws("Typescript to file: ")
			GetString(lv Parm>>PARM.TSFileName)
			TypeScriptChars()
			Parm>>PARM.TypeScriptLength = -1
			TypeScriptStart()
			endcase
		case $I: case $i:
			test Parm>>PARM.TypeScriptLength eq 0
			ifso Ws("No typescript!")
			ifnot [
				Parm>>PARM.tsTypeIn= not Parm>>PARM.tsTypeIn
				Ws("TypeScriptChars In: ")
				OnOff(Parm>>PARM.tsTypeIn)
				]
			endcase
		case $O: case $o:
			test Parm>>PARM.TypeScriptLength eq 0
			ifso Ws("No typescript!")
			ifnot [
				Parm>>PARM.tsTypeOut= not Parm>>PARM.tsTypeOut
				Ws("TypeScriptChars Out: ")
				OnOff(Parm>>PARM.tsTypeOut)
				]
			endcase
		case $N: case $n:
			Ws("New connection (break current one) [Confirm] ")
			switchon GetKey() into
				[
				case $*n: case $Y: case $y:
					Ws("Yes"); Running=2; endcase
				default:
					Ws("No")
				]
			endcase
      case $?:
        Ws(" ?")
        Ws("*NC=Control chars, D=Do file name, E=Echo Change, F=Font file name")
        Ws("*NI=TypeScriptInput, M=IBM-PC mode change, N=New connection")
	Ws("*nO=TypeScript Output, R=Receive file, Q=Quit, S=Send file")
	Ws("*nT=Typescript to file, X=Line feed switch")
         endcase
		default:
			Ws("Unknown command.")
			endcase
		]
	DirectKeys(DIS)
	]
if Running ge 2 then
	[
	Unqueue(ctxQ, tyiCtx)
	Unqueue(ctxQ, tyoCtx)
	Closes(TTYStr)
	TypeScriptChars()		//Flush ts.
	pleaseFinish = Running ge 4 %
	 (Running eq 3 & not (makeBootFile % Parm>>PARM.Server ne 0))
	Running=0			//All finished!
	]
] repeat

// Various error code.

// Stream Errors: simply arrange to return a flag value that indicates
// what has happened:
//	-1:	Mark
//	-2:	Interrupt (not yet implementable!)
//	-3:	Grounds for closing connection (bad state)

and TTYHandleFinish(code) be
[
	@lvUserFinishProc=savedUFP
	let tim=nil
	SetTimer(lv tim, 3000)	// Thirty seconds
	if Running then Running=2	//Flag to stop everything
	until Running eq 0 % TimerHasExpired(lv tim) do
		CallContextList(ctxQ!0)
]

and ChatHandleBSPError(str, ec) = valof
[
	switchon ec into
	[
	case ecMarkEncountered:
		resultis -1
	default:			//Bad status -- connection to close
		Block()		//Give other guy chance to run
		resultis -3
	]
]

//Called when an error, interrupt, or abort pup is received, and handed
// the very pup.

and ChatHandlePup(pbi) be
[CPE
let woffs = nil
switchon pbi>>PBI.pup.type into
[
case typeError:
	[
	unless pbi>>PBI.pup.words↑11 eq 2 endcase
	pbi = BigStack(pbi)
	CaretOff()
	Ws("*n[Error]")
	woffs = 12
	docase -1
	]
case typeAbort:
	[
	pbi = BigStack(pbi)
	CaretOff()
	Ws("*n[Abort]")
	woffs = 1
	docase -1
	]
case -1:
	[
	let C=lv pbi>>PBI.pup.bytes
	let sl=pbi>>PBI.pup.length-2*woffs-21	//Text length+1
	let fp=C+woffs-1
	@fp=(sl lshift 8)+#40	//Length,,space
	Ws(fp)			//Print message if any
	pbi = SmallStack(pbi)
	endcase
	]
// Should really check socket, but not easy....
case typeInterrupt:
	[
	MarkCount=MarkCount+1	//Grumble.....
	endcase
	]
]
ReleasePBI(pbi)
]CPE

//TypeScript routines
// TypeScriptStart() called to get it going.
// TypeScriptChars(byte) called to stuff chars into it.
//	TypeScriptChars(-2) -- check timer and flush if needed
// TypeScriptChars() flushes the current buffers to the disk.

and TypeScriptStart() be
[TSS
	if TStream ne 0 then [ BigStack(); Closes(TStream); SmallStack() ]
	TStream = 0
	let name = lv Parm>>PARM.TSFileName
	if Parm>>PARM.TypeScriptLength eq 0 % name>>STR.length eq 0 %
		makeBootFile then return

	name = BigStack(name)
	let s=OpenFile(name, ksTypeReadWrite, charItem, 0, lv Parm>>PARM.TypeScriptFP)
	test s eq 0
	 ifso [ Ws("*nCannot open typescript file.") ]
	 ifnot [
		if Parm>>PARM.TypeScriptLength ne -1 then
			SetFilePos(s, 0, Parm>>PARM.TypeScriptLength)
		TruncateDiskStream(s)	//And make this the end.
		TStream=s				//Stream to use.
		TToGoTillWrap=0			//Flag to wrap on next output
		tsToFlush=-TypeScriptFlushCount
		SetTimer(lv tsTimer, TypeScriptTimeOut)
		]
	Zero(lv Parm>>PARM.TypeScriptFP, lFP)
	SmallStack()
]TSS

and TypeScriptChars(arg ;numargs n) be
[TSC

let TS2(arg) be
[TS
test arg eq -1 % tsToFlush eq 0 % TimerHasExpired(lv tsTimer) then
	[			//Flush
	tsToFlush=-TypeScriptFlushCount-3
	SetTimer(lv tsTimer, TypeScriptTimeOut)
	if Parm>>PARM.TypeScriptLength ne -1 then
		[
		let old=TToGoTillWrap
		let v=vec 1
		FilePos(TStream, v)
		TS2($<)
		TS2($=)
		TS2($>)
		SetFilePos(TStream, v)
		TToGoTillWrap=old
		]
	if arg ge 0 then TS2(arg)
	CleanupDiskStream(TStream)
	]
  or if arg ge 0 then
	[
	tsToFlush=tsToFlush+1
	if arg eq #12 & Parm>>PARM.LineFeeds eq false then return
	if TToGoTillWrap eq 0 & Parm>>PARM.TypeScriptLength ne -1 then
	   [
	   TToGoTillWrap=-Parm>>PARM.TypeScriptLength
	   Resets(TStream)		//Back to beginning
	   ]
	TToGoTillWrap=TToGoTillWrap+1
	Puts(TStream,arg)
	]
]TS

and TSError(s, ec) be
[
test ec eq 1102  // ecEof
ifso	[
	Ws("*nYour Alto disk is full; typescript closed.")
	Closes(TStream); TStream = 0
	ReturnFrom(TS2)
	]
ifnot SysErr(s, ec)
]

if TStream eq 0 then return 
arg=BigStack(((n eq 0)? -1, arg))
TStream>>ST.error = TSError
TS2(arg)
TStream>>ST.error = SysErr
SmallStack()
]TSC
	
//ScreenSetUp()
// [ statics ScreenBuffer, ScreenBufferLength set up ]
// Gets font, opens stream for display.
// Result is the static DIS to use as display stream
// Can be called repeatedly without damage.

and ScreenSetUp() be
[SSU
	BigStack()

	GetFontPointer()			//Get current font
	if DIS then Closes(DIS)	//Delete previous version
//Compute max size of screen available for text
	let lin=808-15			//Available scan-lines
	let a=@#420
	while a do				//Subtract those already in use
		[
		lin=lin-a>>DCB.height*2
		a=@a
		]
	lin=lin/((FontPointer!-2 +1)&(-2))	//Divide by font height
	unless Parm>>PARM.CalcScreenParms then lin=Parm>>PARM.ScreenLines

	DIS = CreateDisplayStream(lin, ScreenBuffer, ScreenBufferLength, FontPointer)
	SystemScroll=DIS>>DS.scroll
	DIS>>DS.scroll=MyScroll
	ShowDisplayStream(DIS)
	if Parm>>PARM.CalcScreenParms then
	   [
//Now divide, but subtract one.  This is because MAXC believes that
// lines are scrolled on <lf>, but OS display routines believe they are
// scrolled on <cr>.  MAXC types the "bells" and stops output between
// the <cr> and <lf>
	   Parm>>PARM.ScreenLines=lin-1
	   if Parm>>PARM.ScreenLines gr 127 then Parm>>PARM.ScreenLines=127
	   let wA=CharWidth(DIS, $A)
	   let wa=CharWidth(DIS, $a)
	   Parm>>PARM.ScreenChars=(38*16*4)/(wA+3*wa)-3
	   if Parm>>PARM.ScreenChars gr 127 then Parm>>PARM.ScreenChars=127
	   SendTermType=true	//Flag to send screen params to Net.
	   ]
	SmallStack()
]SSU

// MyScroll makes carriage return and line feed honestly interpreted
// by Chat.
and MyScroll(ds, char; numargs n) = valof
[MS
	static farthestRight

	if n eq 1 then resultis SystemScroll(ds)
	switchon char into
	[
	case #15:
		[
		let r=GetBitPos(ds)
		if r gr farthestRight then farthestRight=r
		SetBitPos(ds, GetLmarg(ds))
		resultis char
		]
	case #12:
		[
		let r=GetBitPos(ds)
		if r ls farthestRight then SetBitPos(ds, farthestRight)
		farthestRight=0
		resultis SystemScroll(ds, #15)
		]
	default:
		unless Parm>>PARM.ControlChars do
			if char ls #40 & char ge 0 resultis false
	case #11:
		resultis SystemScroll(ds, char)
	]
]MS

//GetFontPointer(fnam)
// Set up a font to use.  fnam is the name of the font (no name=>
// use system font). Returns font pointer.

and GetFontPointer() be
[
	let def=GetFont(dsp)		//System font!!!!
	if FontPointer ne 0 & FontPointer ne def then
		Free(ChatZone, FontPointer-2)

	let fnam=lv Parm>>PARM.FontName
FontPointer= valof [
// Do not attempt to read font file if Chat was booted
	if makeBootFile % fnam>>STR.length eq 0 then resultis def
	let s=OpenFile(fnam, ksTypeReadOnly)
	if s eq 0 then
		[			//Try with .AL
		let len=fnam>>STR.length
		fnam>>STR.char↑(len+1)=$.
		fnam>>STR.char↑(len+2)=$A
		fnam>>STR.char↑(len+3)=$L
		fnam>>STR.length=len+3
		s=OpenFile(fnam, ksTypeReadOnly)
		if s eq 0 then
			[
			Ws("*NUnable to find font file.")
			resultis def
			]
		]
	let len=FileLength(s)/2
	let font=Allocate(ChatZone, len, true)	//Get core for it.
	if font eq 0 then
	   [
	   Ws("*NNo room for font storage")
	   Closes(s)
	   resultis def
	   ]
	Resets(s)
	ReadBlock(s,font,len)		//Read font
	Closes(s)
	resultis font+2			//Point to 3rd word
	]

]