//MMenu.bcpl 18 May 1983

get "mcommon.d"
get "mdecl.d"
get "streams.d"

external [
// OS
	Puts; Resets; Gets; Closes; Endofs; Zero; Noop; Min; Timer
	DoubleAdd; GotoLabel

// MIDAS
	MidasSwat; PrintTime

// MASM
	@MBlock; ErrorProtect; SymbKeyComp; Wss; ResetsCSS; ResetsCS1
	DoubleNeg

// MIOC
	Wns

// MSYM
	SkipBlankToken; @StringVec

// MTXTBUF
	InputStream; InputTextBuffer; ClearInText; TxtBufClearFlag

// MDISP
	Blink; DisplayOff; @NewLx; @NewCx; DisplayMaxrcx; Displayalx

// MRGN
	UpdateDisplay; PaintSetup; PaintItem; PaintMark
	UpdateEveryTime; SelectedRegion; ScreenLinesDirty

// MMPRGN
	MPDdeSelect

// MCMD
	ShowActionForm; DisplayError; ErrorAbort; CmdStopWCAct
	CmdCommentStream; CmdCS1; TextCmdOutStream; CmdMDFS; CFOutStream
	TimeoutF; DoOverlayRestart

// xxACTIONS
	ActionBlock; ActionPtr; NoopAction; BugValAct
	EscAction; CRAction; NewEscAction; NewCRAction

// Defined here
	CreateAction; ForgetTemporaryActions; DoAction; DoTextAction
	ExecuteTextCmdStream; LookUpMenu; PrintActionTime
	FormMenu; MarkMenus; WssMark; @WsMarkA; WssMAct
	MenuMChange; deSelectMenu
	CommandCount; SkipCommandCount; SkipName; AbortingCFile
	@ItemV; ItemStream; @CurrentMDFS; CFileStream
	EscMBunion; EscMDFS; EscInputText; ThisAction; TimeStartAction

// Defined here for init only
	LastPermanentAction; MenuBlock
]

static[ ItemStream; @ItemV; @CurrentMDFS
	LastPermanentAction; MenuBlock
	CommandCount = 0; SkipCommandCount = 0; SkipName; CFileStream = 0
	AbortingCFile = 0
	EscMBunion = TopButton; EscMDFS; EscInputText; ThisAction
	@InLine; @Height; @ProcNMax; @TextLines; @SizeVec; @ProcVec
	TimeStartAction
]

let LookUpMenu(Letter,LineN) = valof
[	if LineN ge MaxLineN then resultis 0
	let LetterV = Letter-$A
	LetterV = (LineN < 0) ? LetterV,(LetterV*MaxLineN)+LineN+($Z-$A+1)
	resultis LetterV > MaxMenus ? 0,MenuBlock!LetterV
]


and CreateAction(Name,lvProc,Arg,lvMProc,Char,TO; numargs NA) = valof
[	if ActionPtr ge MaxActions then MidasSwat(ActionOVF)
	let B = ActionBlock+ActionPtr*(size Action/16)
	B>>Action.Name = Name
	B>>Action.lvProc = lvProc
	B>>Action.lvMProc = NA < 4 ? 0,lvMProc
	B>>Action.Arg = Arg
	(lv B>>Action.Char)!0 = 0
	if NA ge 5 do
	[ B>>Action.Char = Char
	  if NA ge 6 then B>>Action.ifTO = TO
	]
	ActionPtr = ActionPtr+1
	resultis B
]


and ForgetTemporaryActions() be ActionPtr = LastPermanentAction


and LookUpAction(Name) = valof
[	let B,C = ActionBlock,ActionBlock+(ActionPtr*(size Action/16))
	while B < C do
	[ if SymbKeyComp(B>>Action.Name,Name) eq 0 then resultis B
	  B = B+(size Action/16)
	]
	resultis 0
]


and DoTextAction(Char) be
[	let Action = valof
	[ let B,C = ActionBlock,ActionBlock+(ActionPtr*(size Action/16))
	  while B < C do
	  [ if B>>Action.Char eq Char then resultis B
	    B = B+(size Action/16)
	  ]
	  resultis 0
	]
	test Action eq 0
	ifso Blink()
	ifnot DoAction(Action,TopButton,CmdMDFS)
]

and DoAction(Action,MBunion,MDFS) be
[	Timer(TimeStartAction); DoubleNeg(TimeStartAction)
//Flush trailing blanks in input text except for BugValAct.
//Reset input text for BugValAct when indicated
	test (Action eq BugValAct) & ((MBunion & BottomButton) ne 0)
	ifso if TxtBufClearFlag then Resets(InputStream)
	ifnot while InputTextBuffer!(InputTextBuffer!0) eq $  do
		InputTextBuffer!0 = InputTextBuffer!0-1
//Insert a bogus TimeOut action sequence around commands that require
//this in command files.  Actions from a command file aren't written on
//the output file.
	if (TextCmdOutStream ne 0) & (Action ne CmdStopWCAct) &
		(CFileStream eq 0) then
	[ let TimeoutRequired = Action>>Action.ifTO
	  if TimeoutRequired ne 0 then
	    Wss(TextCmdOutStream,"L X TimeOut 10000*N")
	  WLogicalActToS(TextCmdOutStream,MBunion,MDFS,Action)
	  Puts(TextCmdOutStream,$*N)
	  if TimeoutRequired ne 0 then
	    Wss(TextCmdOutStream,"L X Skip 1*NL X ShowError Timed out*N")
	]
	let SvEscAction,SvCRAction = EscAction,CRAction
	let EscCRChange = false
	test Action>>Action.ifEsc ne 0	//EscAction = ThisAction
	ifso
	[ NewEscAction,EscMBunion,EscMDFS = Action,MBunion,MDFS
	  MBlock(EscInputText,InputTextBuffer,InputTextBuffer!0+1)
	  NewCRAction = NoopAction
	  EscCRChange = true
	]
	ifnot if Action>>Action.ifResEsc ne 0 do
	  [ NewEscAction,NewCRAction = NoopAction,NoopAction
	    EscCRChange = true
	  ]
//EscAction and CRAction point at NoopAction during an action so that
//typing ahead won't crash.
	EscAction,CRAction = NoopAction,NoopAction
	ClearInText()		//Set flag so next in char clears
	if Action>>Action.ifNoRes eq 0 do
	[ ResetsCSS(); ResetsCS1()
	]
	ThisAction = Action	//Special kludge so RdCmds can get
				//at Action>>Action.lvMProc used as an arg
	ErrorProtect(Action>>Action.lvProc,Action>>Action.Arg,
		MBunion,MDFS)
//If this action changes EscAction and CRAction then pickup changes,
//else restore previous values.
	test EscCRChange
	ifso [ EscAction,CRAction = NewEscAction,NewCRAction ]
	ifnot [ EscAction,CRAction = SvEscAction,SvCRAction ]
	PrintActionTime()
]


and PrintActionTime() be
[	let T = vec 1; Timer(T); DoubleAdd(T,TimeStartAction); PrintTime(T)
]

//Execute command file.  ExecuteTextCmdStream is called from the top level
//procedure InitRes() on "RdCmds" or "RunProg" actions; a stack of nested
//command files is maintained.  Recursive calls of ExecuteTextCmdStream occur
//on "command overlay" actions via StartCmdOverlay.  Both normal and command
//file syntax error terminations return from the ErrorProtect below;
//continuing from a syntax error will shutdown the current command file and
//resume the next higher command file.  Continuing from an error that occurs
//within an action will resume the current command file.  However, continuing
//from either a syntax or action error while in a command overlay will first
//shut down the overlay and then resume the command file in progress.
and ExecuteTextCmdStream(S) be
[	let OldCFileStream = CFileStream; CFileStream = S
//Trap command file errors here; ExecuteTCS1 returns 1 normally, 0
//after a comfile error.
	let R = ErrorProtect(lv ExecuteTCS1,S)
//Careful here because a single command file may result in several
//calls to ExecuteTextCmdStream during "Go" or other commands that do
//StartCmdOverlay.  Hence, only cleanup when OldCFileStream is different.
	if CFileStream ne OldCFileStream do
	[ Closes(S)
	  SkipCommandCount = (AbortingCFile ne 0) ? AbortingCFile-1,0
	  if (CFileStream eq 0) % (AbortingCFile > 0) then
		AbortingCFile = 0
	  CFileStream = OldCFileStream
	  if (R ne 0) & (SkipName!0 ne 0) then
		ErrorProtect(lv DisplayError,"Undefined tag ",0,SkipName)
	]
]


and ExecuteTCS1(S) = valof
[   CommandCount,SkipName!0 = 0,0
    let ABuf = vec 100
//Loop over all text lines in command file
    [ let ALength,APtr,semiF,Char = 0,1,false,nil
//Read in command line stripped of any comment, replacing tabs by blanks
      [ if Endofs(S) % (AbortingCFile ne 0) then resultis -1
	Char = Gets(S)
	if Char eq $*N then break
	if Char eq $; then semiF = true
	if semiF then loop		//Flush comment
	if ALength ge 99 then ErrorAbort("Line too long")
	ALength = ALength+1; ABuf!ALength = Char eq $*t ? $ ,Char
      ] repeat
//Flush the text line if not enough on it
      if ALength le 1 then loop
      ABuf!0 = ALength
      let CPos = 0
//Collect ".TAG", if any, and match against searched for tag, if any
      if ABuf!APtr eq $. do
      [	APtr = APtr+1
	while APtr le ALength do
	[ Char = ABuf!APtr; APtr = APtr+1
	  if Char eq $  then break
	  CPos = CPos+1; StringVec>>CV↑CPos = Char
	]
	StringVec>>lh = CPos
	if SymbKeyComp(StringVec,SkipName) eq 0 then SkipName!0 = 0
      ]
//If skipping commands then don't parse further
      if SkipName!0 ne 0 then loop
      SkipBlankToken(ABuf,lv APtr)
//Make sure got a real command before applying skip test
      if (ALength - APtr) le 1 then loop
      if SkipCommandCount > 0 do
      [	SkipCommandCount = SkipCommandCount-1; loop
      ]
//Collect mouse buttons terminated by blank
      let Buttons,Action = 0,0
      while APtr le ALength do
      [	Char = ABuf!APtr
	APtr = APtr+1
	if Char eq $  then break
	Buttons = Buttons logor selecton Char into
	[ case $L:  TopButton
	  case $M:  MiddleButton
	  case $R:  BottomButton
	  default: -1
	]
      ]
      if Buttons le 0 then ErrorAbort("Bad mouse button")
// Collect menu char
      SkipBlankToken(ABuf,lv APtr)
      if APtr le ALength do
      [ Char = ABuf!APtr; APtr = APtr+1
      ]
// Collect menu line number
      let N,N1 = -1,nil
      while APtr le ALength do
      [ N1 = ABuf!APtr; APtr = APtr+1
	if (N1 > $9) % (N1 < $0) then break
	N = (N < 0 ? N1,(N*10)+N1) - $0
      ]
      let MDFS = LookUpMenu(Char,N)
      if MDFS eq 0 then ErrorAbort("Undefined menu")
//Collect action name terminated by *N or blank
      CPos = 0
      while APtr le ALength do
      [	Char = ABuf!APtr; APtr = APtr+1
//Flush leading blanks before command line input
	if Char eq $  do
	[ Resets(InputStream)
	  SkipBlankToken(ABuf,lv APtr)
//Put command line text onto command line
	  while APtr le ALength do
	  [ Puts(InputStream,ABuf!APtr); APtr = APtr+1
	  ]
	  break
	]
	CPos = CPos+1; StringVec>>CV↑CPos = Char
      ]
      StringVec>>lh = CPos
      Action = LookUpAction(StringVec)
      if Action eq 0 then ErrorAbort("Undefined action ",StringVec)
      if not DisplayOff do	// Show what's happening
      [ deSelectMenu(SelectedRegion)
//Displace from beginning of MDFS structure back to ProcVec
	PointPV(MDFS)
	let N = 0
	for I = 1 to ProcVec!0 do if ProcVec!I eq Action then
	[ N = I; break
	]
	MenuMarkItems(MDFS,N)
	SelectedRegion = MDFS
	UpdateEveryTime(); UpdateDisplay()
      ]		// End of display update
//CommandCount controls command file timeouts; ordinarily it is le 0.
//Actions which use the EveryTimeList will return from DoAction() before
//completion, but cfile execution must not resume until QuitCmdOverlay()
//is called later by an EveryTimeList procedure; in the meantime DriverLoop()
//must run the EveryTimeList and display.  These actions require a preceding
//TimeOut action, which sets CommandCount=2.  For "Go", the action which
//starts the command overlay is the one requiring Timeout, so DriverLoop is
//immediately called by DoOverlay; for "Test" and "TestAll", a later action
//in the command overlay requires a timeout, so DoOverlay first calls
//ExecuteTextCmdStream to get intervening actions from the command file; then
//the GotoLabel below aborts back to DoOverlay, which will call DriverLoop()
//until the command overlay terminates with QuitCmdOverlay.
      CommandCount = CommandCount-1
      test CommandCount > 0	//Preceding TimeOut?
      ifso test Action>>Action.ifTO eq 0
	ifso
	[ ResetsCSS(); ErrorAbort("Illegal TimeOut before ",StringVec)
	]
	ifnot
	[ DoAction(Action,Buttons,MDFS)
	  GotoLabel(TimeoutF,DoOverlayRestart,0)
	]
      ifnot test Action>>Action.ifTO ne 0
	ifso
	[ ResetsCSS(); ErrorAbort("Missing TimeOut before ",StringVec)
	]
	ifnot
	[ CommandCount = 0
	  DoAction(Action,Buttons,MDFS)
	]
  ] repeat
]

//The MDFS structure is preceded by the TextLines, SizeVec, and ProcVec
//vectors, as discussed in MDECL.D.  Setup pointers to these and store
//several other interesting values in statics
and PointPV(MDFS) be
[	Height,ProcNMax = MDFS>>MDFS.Rgn.Height,MDFS>>MDFS.ProcNMax
	TextLines = MDFS-Height
	SizeVec = TextLines-((Height+ProcNMax) rshift 1)
	ProcVec = SizeVec-ProcNMax

]


//Call the procedure for forming the menu
and FormMenu(MDFS,Proc,nil) be
[	CurrentMDFS = MDFS
	PointPV(MDFS); Zero(ProcVec,MDFS-ProcVec)
	InLine = 0
//ItemV is a TextVec that is filled with successive items by MarkMenus
	ItemV!0 = 0
	PaintSetup(MDFS,InLine)
//Call the procedure for forming the menu--it will make calls on MarkMenus
//(usually via WsMarkA) to add successive menu items to the region
	Proc(ItemStream,MDFS)
	MDFS>>MDFS.inLine = InLine+1
	MDFS>>MDFS.SelectedItem = 0
	MenuSelectItem(MDFS)
]


//The setup for MarkMenus is carried out by FormMenu.
and MarkMenus(Action) be
[	if ProcVec!0 ge ProcNMax-1 then
	  test Action eq 0; ifso return; ifnot MidasSwat(TooManyActions)
	let Size = ItemV!0
//No text in ItemV is a carriage return
	if (TextLines!InLine + Size > DisplayMaxrcx) % (Size eq 0) then
	[ if InLine+1 ge Height then return
	  InLine = InLine+1; PaintSetup(CurrentMDFS,InLine)
	  if Size eq 0 then return
	]
	ProcVec!0 = ProcVec!0 + 1
	ProcVec!(ProcVec!0) = Action
	let Z,SVZ,I = 0,nil,1
	[ SVZ = (SizeVec>>CV↑Z)+1
	  if I > InLine then break; I = I+1; Z = Z+SVZ
	] repeat
	SizeVec>>CV↑Z = SVZ
	SizeVec>>CV↑(Z+SVZ) = Size
	PaintItem(Displayalx+InLine,ItemV,TextLines!InLine)
	TextLines!InLine = TextLines!InLine + Size
	ItemV!0 = 0
]


and WssMAct(Act) be
[	Wss(ItemStream,Act>>Action.Name); MarkMenus(Act)
]


and WssMark(Name,Act) be
[	Wss(ItemStream,Name); MarkMenus(Act)
	Puts(ItemStream,$ ); MarkMenus(0)
]


and WsMarkA(Act) be
[	WssMAct(Act); Puts(ItemStream,$ ); MarkMenus(0)
]

//Called from FormMenu and MenuMChange, each of which has called PointPV
and MenuSelectItem(MDFS) be
[	let X,N = 0,0
	if MDFS>>MDFS.mIn ne 0 do
	[ let rlx = Min(NewLx-MDFS>>MDFS.Rgn.aLineX,MDFS>>MDFS.inLine)
	  let rcx = NewCx-MDFS>>MDFS.Rgn.aCharX
	  let SVX,I = nil,1
	  [ SVX = SizeVec>>CV↑X; if I ge rlx then break
	    I = I+1; N = N+SVX; X = X+SVX+1
	  ] repeat
	  let Y = 0
	  for I = 1 to SVX do
	  [ Y = Y + SizeVec>>CV↑(X+I)
	    N = N + 1; if Y ge rcx then break
	  ]
	]
	MenuMarkItems(MDFS,N)
]


//Called from ExecuteTextCmdStream, MenuSelectItem, and deSelectMenu, each
//of which has called PointPV
and MenuMarkItems(MDFS,N) be
[	let OldMenuItem = MDFS>>MDFS.SelectedItem
	if OldMenuItem ne N then
	[ MenuMarkSItem(MDFS,OldMenuItem,0)
	  MenuMarkSItem(MDFS,N,200B)
	  MDFS>>MDFS.SelectedItem = N
	  ScreenLinesDirty = true
	]
]


//Called from MenuMarkItems.  PointPV has been called already.
//Flag is 200B (white-on-black) or 0 (normal)
and MenuMarkSItem(MDFS,N,Flag) be
[	if N eq 0 then return
	if (ProcVec!N eq 0) & (Flag ne 0) then return
//X is rlx (relative line number)
//Y points at the size of the current item
//M is the item number
	let X,Y = 0,0
	[ let SVY = SizeVec>>CV↑Y
	  if SVY ge N then break
	  X = X+1; N = N-SVY; Y = Y+SVY+1
	] repeat
	let charX = 1
	for I = 2 to N do
	[ Y = Y+1; charX = charX+SizeVec>>CV↑Y
	]
	PaintMark(MDFS,X,charX,(SizeVec>>CV↑(Y+1))+charX-1,Flag)
]


and WLogicalActToS(S,MB,MDFS,Act) be
[	if (MB & TopButton) ne 0 then Puts(S, $L)
	if (MB & MiddleButton) ne 0 then Puts(S, $M)
	if (MB & BottomButton) ne 0 then Puts(S, $R)
	Puts(S, $ )
	Puts(S,MDFS>>MDFS.Letter)
	let L = MDFS>>MDFS.LineN
	if (L ge 0) & (L le MaxLineN) then Wns(S,L,0,10)
	Puts(S, $ ); Wss(S,Act>>Action.Name); Puts(S, $ )
	for I = 1 to InputTextBuffer!0 do Puts(S, InputTextBuffer!I)
]

//deSelectMenu and MenuMChange are the entries to the menu stuff from
//MRGN.BCPL.  Because of the way MPD, MDFS, and RGN structures nest,
//a pointer to MPD is also a pointer to MDFS and to RGN.

//At present the two kinds of menu are the command menu (nothing special
//on deselect) and the name-value menus.
and deSelectMenu(R) be
[	if R>>Rgn.Type ne MenRgn then return
	if R ne CmdMDFS do MPDdeSelect(R)
	R>>MDFS.mIn = 0; PointPV(R); MenuMarkItems(R,0)
	if ShowActionForm then ResetsCSS()
]


//MenuMChange is only called from DriverLoop when the mouse buttons,
//line, or character position have changed, when the newly selected
//region is a menu region, and when actions in that menu region are
//legal (When an error menu is up, only command menu actions are legal).

//MenuMChange first calls Action.lvMProc; lvMProc will not be called
//during command files, so its effects should be limited to menu
//modifications.  lvMProc can also print stuff on CmdCS1 but cannot
//use CmdCommentStream because ShowActions uses that.  At present only
//the MPD menus make use of lvMProc (MPDMChange is called to show the
//menu "underneath" the one over which the buttons are depressed).

//DoAction is called if the mouse is still in the same region that it
//was in when the first button was depressed, and if mouse buttons have
//just become 0 after being non-0.
and MenuMChange(R,InR,MB,MBunion) be
[	R>>MDFS.mIn = InR
	PointPV(R); MenuSelectItem(R)
	let Item = R>>MDFS.SelectedItem
	if Item > 0 do
	[ let Action = ProcVec!Item
	  if Action ne 0 do
	  [ if ShowActionForm then
	    [ ResetsCSS()
	      WLogicalActToS(CmdCommentStream,MBunion,R,Action)
	    ]
//The lvMProc word in the Action structure is sometimes used for an
//extra argument (small integer < #1000)
	    if (Action>>Action.lvMProc & 177000B) ne 0 then
	      ErrorProtect(Action>>Action.lvMProc,
		Action>>Action.Arg,R,MBunion,MB)
	    if (MB eq 0) & (MBunion ne 0) & InR then
	      DoAction(Action,MBunion,R)
	  ]
	]
]