// DKS.bcpl -- Display and Keyboard Support
// Copyright Xerox Corporation 1979, 1983
// Last modified January 8, 1983  3:50 PM by Boggs

get "AltoDefs.d"
get "SysDefs.d"
get "Disks.d"
get "Streams.d"
get "AltoFileSys.d"
get "Time.d"
get "ComStruct.bcpl"


static
	[ ScrollResult
	UserLineCheckpoint
	UserBitCheckpoint
	UserLines = defaultUserLines  // size of display
	UserLineEnds		// vector 0..UserLines-1 of endpoints
	BoldFont = 0
	RegularFont = 0
	PreTimeDcb
	ScrollsSinceOK
	ShouldSetTime
	ShowTime
	TimeOutCommand = 0
	TIMESTR1
	TIMESTR2
	USERSTR
	]


manifest
	[ DisplayHead = #420
	]


let WriteSys(C) be

	[ WriteChars(C, 0, dsp)
	]


and WRITE(C, BreakBetweenPages; numargs na) = valof

	[ if na ls 2 then BreakBetweenPages = false
	unless BreakBetweenPages do ScrollsSinceOK = 0
	resultis WriteChars(C, 0, USERSTR)
	]


and RESETPAGE(S) be

	[ ScrollsSinceOK = 0
	]


and WriteChars(C, RTN, Stream) = valof

	[ ScrollResult = 0

	test (C ge 0) & (C le #377)

	ifso test RTN eq 0

		ifso	[ Puts(Stream, C & #177)
			resultis ScrollResult
			]

		ifnot	resultis RTN(C & #177)	// MASK TO 7 BITS

	ifnot	[ let L = C>>STRING.length
		let T = 0
		let I = 1

		while (T eq 0) & (I le L) do
			[
			let char = C>>STRING.char↑I
			switchon char into
			    [
			    case #300: [ Bold(Stream); endcase ]
			    case #301: [ UnBold(Stream); endcase ]
			    default: T = WriteChars(char, RTN, Stream)
			    ]
			I = I+1
			]
		resultis T
		]

	]


and PRETTYWRITE(C) = valof

	[ let BlankWidth = CharWidth(USERSTR, $*S)
	let ColWidth = 10*BlankWidth

	let CurPos = GetBitPos(USERSTR)
	let NewPos = ((CurPos+3*BlankWidth)/ColWidth+1)*ColWidth

	let CWidth = BitWidth(USERSTR, C)

	test CWidth+NewPos ge GetRmarg(USERSTR)

	ifnot SetBitPos(USERSTR, NewPos)

	ifso 	[ let Result = WRITE($*N, true)
		if Result ne 0 then resultis Result
		]

	resultis WRITE(C, true)
	]


and CanOverlay() = valof
	[
	static [ free ]
	let Check(od) be
		unless ReleaseOverlay(od, true) do free = false
	free = true
	LockPendingCode()
	GeneratePresentOverlays(Check)
	resultis free
	]


and TwiddleThumbs(TimeOutQ) be

	[ manifest
		[ // 20 minutes is 1,200,000 1 ms ticks
		TwentyMinHi = 18	// x/65536
		TwentyMinLo = 20352	// x mod 65536
		 // 1 minutes is 120,000 1 ms ticks
		OneMin = 165140b	// 60000d
		]

	let SortTimer = vec 1
	let IdleTimer = vec 1
	let CursorTimer = vec 1
	let SpinDownTimer = vec 1

	let PassNumber = 0
	SETUPCLK(SpinDownTimer, 1000)	// 1 sec

	SETUPCLK(SortTimer, OneMin)
	SETUPCLK(IdleTimer, TwentyMinLo, TwentyMinHi)

	let LineDelta = GetLinePos(USERSTR)-UserLineCheckpoint
	let BitPos = GetBitPos(USERSTR)
	Puts(USERSTR, $*S)

	while Endofs(keys) do
		[ if TIMEHASCOME(SpinDownTimer) &
			(@DiskStatus & #40) ne 0 then
			EtherBoot(0)

		SETUPCLK(CursorTimer, 500)	// 1/2 second
		RemoveCursor(UserLineCheckpoint+LineDelta,
				BitPos)
		PassNumber = PassNumber+1
		Puts(USERSTR, (((PassNumber&1) eq 0)? $*S, $|))

		if (@DiskStatus & #40) eq 0 then  // Disk ready
		    [
		    if ShouldSetTime & DIRSTATE eq PAGESCOUNTED &
			CanOverlay() then
			[
			ShouldSetTime = false
			SetTime()
			SETUPCLK(CursorTimer, 500)	// 1/2 second
			SETUPCLK(SortTimer, OneMin)
			SETUPCLK(IdleTimer, TwentyMinLo, TwentyMinHi)
			]
		    SETUPCLK(SpinDownTimer, 1000)	// 1 sec
		    INITDIRBLK(true)  // GET DIRECTORY INTO CORE

		    if directoryOutOfSort & TIMEHASCOME(SortTimer) &
			CanOverlay() then
			[
			directoryOutOfSort = false
			WriteSortedDirectory()
			]
		    if TimeOutQ ne 0 & TIMEHASCOME(IdleTimer) then
			[
			WriteSortedDirectory()
			if TimeOutCommand eq 0 then DIAGNOSE()
			STRINGTOQR(TimeOutCommand, TimeOutQ)
			PUTQR(TimeOutQ, $*n)
			break
			]
		    ]

		let tlc = 0
		until TIMEHASCOME(CursorTimer) % (not Endofs(keys)) do
		    [
		    if (tlc&7) eq 0 then MAKETIMELINE()
		    tlc = tlc + 1
		    ]
		]

	RemoveCursor(UserLineCheckpoint+LineDelta,
			BitPos)
	]


and RemoveCursor(BLine, BBitPos) be

	[ let CurLine = GetLinePos(USERSTR)
	while CurLine gr BLine do
		[ ResetLine(USERSTR)
		CurLine = CurLine-1
		SetLinePos(USERSTR, CurLine)
		]

	SetBitPos(USERSTR, BBitPos)
	EraseBits(USERSTR, GetRmarg(USERSTR)-BBitPos)
	SetBitPos(USERSTR, BBitPos)
	]


and FlashScreen() be

	[
	let invert() be
	  [
	  let dcb = @DisplayHead
	  until dcb eq 0 do
	    [ dcb>>DCB.background = dcb>>DCB.background xor 1
	    dcb = dcb>>DCB.next
	    ]
	  ]

	invert()
	let FlashTimer = vec 2
	SETUPCLK(FlashTimer, 250)	// 1/4 second
	let dummy = 250
	until TIMEHASCOME(FlashTimer) do [ dummy = dummy*dummy ]
	invert()

	]


and Bold(Stream) be

	[
	if RegularFont eq 0 then SetUpBold(Stream)
	SetFont(Stream, BoldFont)
	]


and UnBold(Stream) be

	[
	if RegularFont eq 0 then SetUpBold(Stream)
	SetFont(Stream, RegularFont)
	]


and SetUpBold(Stream) be

	[
	RegularFont = GetFont(Stream)
	BoldFont = Allocate(CZ,2)+2
	BoldFont!-2 = -1
	BoldFont!-1 = RegularFont
	]


and InitUserLine(Prompt) be

	[ WRITE($*N)
	WRITE(Prompt)

	UserLineCheckpoint = GetLinePos(USERSTR)
	UserBitCheckpoint = GetBitPos(USERSTR)
	]


and FitsThisLine(S, C, Extra; numargs na) = valof

	[ resultis (GetRmarg(S) gr
			(GetBitPos(S)+BitWidth(S, C)+
				((na ge 3)? Extra, 0)))
	]


and BitWidth(S, C) = valof

	[ if (C le 0) % (C ge #377) then
		[ let Sum = 0
		for i=1 to C>>STRING.length do
			Sum = Sum+CharWidth(S, C>>STRING.char↑i)
		resultis Sum
		]

	resultis CharWidth(S, C)
	]



and UserScroll(ds, char; numargs na) = valof

	[ if na ls 2 then resultis DefaultScroll(ds)

	switchon char into
	   [
	   case $*N: endcase
	   case #11:	// tab
	      resultis DefaultScroll(ds, char)
	   case $*L: case 0:	// null, lf
	      resultis char
	   case -1:	// about to burp lines up one
	      resultis TestScrollCount(ds)
	   case -2:	// about to lose data off top of screen
	      resultis char
	   default:
	      [
	      test char ls #40
	         ifso [ Puts(ds, $↑); Puts(ds, char+#100) ]
	         ifnot endcase
	      resultis char
	      ]
	   ]
	let curBit = GetBitPos(ds)
	let rpos = CharWidth(ds, char) + curBit
	if rpos le GetRmarg(ds) then // char really fits
	  resultis DefaultScroll(ds, char)
	let curLine = GetLinePos(ds)
	UserLineEnds!curLine = curBit
	unless SetLinePos(ds, curLine+1) do
		resultis DefaultScroll(ds, char)
	SetBitPos(ds, GetLmarg(ds))
	if char ne $*N then Puts(ds, char)
	resultis char
	]


and TestScrollCount(ds) = valof
	[

	if ScrollsSinceOK ge UserLines-1 then
		[ ScrollsSinceOK = 0
		if LASTONEINKEYS(CONTROLC) ne 0 then
			[ ScrollResult = CONTROLC
			resultis false
			]

		Wss(ds, "*NMore?")
		Resets(keys)

		while Endofs(keys) do
			INITDIRBLK(true)

		if LASTONEINKEYS(CONTROLC) ne 0 then
			[ ScrollResult = CONTROLC
			resultis false
			]

		let c = Gets(keys)
		Puts(ds,$*n)
		switchon c into
			[ case $N:
			case $n:
			case #177:
				ScrollResult = Capitalize(c)
				resultis false

			default:
			]

		while FitsThisLine(ds, $~) do Puts(ds, $~)
		ScrollsSinceOK = 0
		]

	for i = 0 to UserLines-1 do
		UserLineEnds!i = UserLineEnds!(i+1)
	UserLineCheckpoint = UserLineCheckpoint-1

	ScrollsSinceOK = ScrollsSinceOK+1

	resultis true
	]


and OverType(Q, PROMPT) be

	[ if UserLineCheckpoint ls 0 then
		[ RETYPE(Q, WRITE, PROMPT)
		return
		]

	let CurLinePos = GetLinePos(USERSTR)
	let CurBitPos = GetBitPos(USERSTR)

	SetLinePos(USERSTR, UserLineCheckpoint)
	SetBitPos(USERSTR, UserBitCheckpoint)

	let SavedULC = UserLineCheckpoint

	MapQ(Q, WRITE)  // This may decrement UserLineCheckpoint

	UserLineCheckpoint = SavedULC

	let NewLinePos = GetLinePos(USERSTR)
	let NewBitPos = GetBitPos(USERSTR)

	EraseBits(USERSTR, GetRmarg(USERSTR)-NewBitPos)

	while NewLinePos ls CurLinePos do
		[ SetLinePos(USERSTR, CurLinePos)
		ResetLine(USERSTR)
		CurLinePos = CurLinePos-1
		]

	SetBitPos(USERSTR, NewBitPos)
	SetLinePos(USERSTR, NewLinePos)
	]


and EraseChar(c) = valof

	[
	if c ls #40 then
	    [
	    if c eq $*T % c eq $*N then resultis false
	    if c eq $*L % c eq  0 then resultis true
	    test EraseChar(c+#100)
		ifso resultis EraseChar($↑)
		ifnot resultis false
	    ]

	let width = CharWidth(USERSTR, c)

	if GetBitPos(USERSTR)-width ge GetLmarg(USERSTR) then
		[ // on this line
		EraseBits(USERSTR, -width)
		resultis true
		]

	let curLine = GetLinePos(USERSTR)
	if curLine eq 0 resultis false

	ResetLine(USERSTR)

	curLine = curLine-1
	SetLinePos(USERSTR, curLine)
	SetBitPos(USERSTR, UserLineEnds!curLine)

	resultis EraseChar(c)
	]


and RETYPE(TOQ, WriteFn, PROMPT) be

	[ if PROMPT eq 0 then return

	test WriteFn eq WRITE

	    ifso
		test UserLineCheckpoint ge 0
		    ifso
			[
			let curLine = GetLinePos(USERSTR)
			until curLine eq UserLineCheckpoint do
				[
				ResetLine(USERSTR)
				curLine = curLine-1
				SetLinePos(USERSTR, curLine)
				]
			SetBitPos(USERSTR, UserBitCheckpoint)
			EraseBits(USERSTR,
			    GetRmarg(USERSTR)-UserBitCheckpoint)
			SetBitPos(USERSTR, UserBitCheckpoint)
			]
		    ifnot InitUserLine(PROMPT)

	    ifnot
		[ WriteFn($*N)
		WriteFn(PROMPT)
		]

	MapQ(TOQ, WriteFn)
	]


and MapQ(Q, Fn) be

	[ let MYQ = vec size QS/16
	INITQ(MYQ)

	until ISEMPTYQ(Q) do
		[ let C = GETQF(Q)
		Fn(C)
		PUTQR(MYQ, C)
		]

	APPENDQ(Q, MYQ, Q)
	]

and LOOKFORCTLC() = valof

	[ let CharNoOfLastCtlC = LASTONEINKEYS(CONTROLC)

	if CharNoOfLastCtlC ne 0 then
		[ for I=1 to CharNoOfLastCtlC-1 do Gets(keys)
		resultis true
		]

	resultis false
	]


and LASTONEINKEYS(char) = valof

	[ let CurrentCharNo = 1
	let CharNoOfLastGoodie = 0

	let NextOut = OsBuffer>>OsBUF.Out
	if NextOut eq OsBuffer>>OsBUF.Last then
		NextOut = OsBuffer>>OsBUF.First

	while NextOut ne OsBuffer>>OsBUF.In do
		[ if @NextOut eq char then
			CharNoOfLastGoodie = CurrentCharNo
		CurrentCharNo = CurrentCharNo+1
		NextOut = NextOut+1
		if NextOut eq OsBuffer>>OsBUF.Last then
			NextOut = OsBuffer>>OsBUF.First
		]

	resultis CharNoOfLastGoodie
	]


and CatchBlankKeys(kbTable) = valof

	[ if kbTable>>KBTRANS.Transition ge 0 then resultis true
	let char = nil
	switchon kbTable>>KBTRANS.Transition & 377b into
	  [
	  case 30: // spare2
	    [ char = 202b; endcase ]
	  case 31: // spare1
	    [ char = 201b; endcase ]
	  case 61: // spare3
	    [ char = 203b; endcase ]
	  default: resultis true
	  ]
	let newIn = OsBuffer>>OsBUF.In + 1
	if newIn eq OsBuffer>>OsBUF.Last then
		newIn = OsBuffer>>OsBUF.First

	if newIn ne OsBuffer>>OsBUF.Out then
	  [
	  @(OsBuffer>>OsBUF.In) = char
	  OsBuffer>>OsBUF.In = newIn
	  ]
	resultis false
	]


and MAKETIMELINE() be

	[
	ShowTime = ShowTime eq TIMESTR1? TIMESTR2, TIMESTR1
	WriteChars(FORMATN("*n-- <S> ",ExecRelease), 0, ShowTime)

	let TIME = vec lenUTV
	UNPACKDT(0, TIME)

	let MESSAGE = vec 100
	test (TIME>>UTV.year ls 1983) % (TIME>>UTV.year gr 1990)

	ifso FORMAT(MESSAGE, " Date and Time Unknown - <D> Pages --",
			sysDisk>>DSK.diskKd>>KDH.freePages)

	ifnot
	    [
	    FORMAT(MESSAGE, " <S>day <S> <D> - <D>:<D 2 $0>:<D 2 $0> <S> - <D> Pages --",
		selecton TIME>>UTV.weekday into
			[ case 0: "Mon"
			case 1: "Tues"
			case 2: "Wednes"
			case 3: "Thurs"
			case 4: "Fri"
			case 5: "Satur"
			case 6: "Sun"
			],
		selecton TIME>>UTV.month into
			[ case 0: "Jan"
			case 1: "Feb"
			case 2: "Mar"
			case 3: "Apr"
			case 4: "May"
			case 5: "Jun"
			case 6: "Jul"
			case 7: "Aug"
			case 8: "Sep"
			case 9: "Oct"
			case 10: "Nov"
			case 11: "Dec"
			],
		TIME>>UTV.day,
		valof
			[ let HOUR = TIME>>UTV.hour
			if HOUR ge 12 then HOUR = HOUR-12
			if HOUR eq 0 then HOUR = 12
			resultis HOUR
			],
		TIME>>UTV.minute,
		TIME>>UTV.second,
		((TIME>>UTV.hour ls 12)? "am", "pm"),
		sysDisk>>DSK.diskKd>>KDH.freePages)
	    ]

	let MSGWidth = BitWidth(ShowTime, MESSAGE)
	while FitsThisLine(ShowTime, $-, MSGWidth) do
		Puts(ShowTime, $-)
	Wss(ShowTime, MESSAGE)
	PreTimeDcb>>DCB.next = ShowTime>>DS.fdcb
	]