Category : Pascal Source Code
Archive   : TOPS.ZIP
Filename : MENUPULL.PAS
INTERFACE
USES IOSTUFF,CRT,DOS;
PROCEDURE RestoreWorkScreen;
PROCEDURE SaveWorkScreen;
PROCEDURE SetMain(MenuStr:AnyStr);
PROCEDURE SetSub(Sub:Integer;SubStr:LongStr);
PROCEDURE WriteSub(Sub:Integer);
PROCEDURE WriteMain;
PROCEDURE RebuildIt;
FUNCTION PickSub(Sub:Integer) : Char;
FUNCTION PickMain : Char;
IMPLEMENTATION
CONST
ColorF1 = Yellow; { Menu Colors }
ColorB1 = Blue;
ColorF2 = LightCyan; { First Letter Colors }
ColorB2 = Blue;
ColorF3 = Black; { Reverse Video bar cursor }
ColorB3 = LightGray;
ColorF4 = LightGray; { Border around submenu }
ColorB4 = Black;
MaxMenuItems = 12;
MaxSubMenuItems = 12;
Sp = 3; { Number of additional pad spaces between }
{ menu picks. Sp = 3 gives 4 spaces total }
XPos = 1; YPos = 1; { Position of main menu. 1st pick padded with Sp above }
VAR
MenuMsg : Array[1..MaxMenuItems] of ShortStr; { Main menu messages }
MenuLtr : Array[1..MaxMenuItems] of Char; { 1st letter of Main }
SubMenuMsg: Array[1..MaxMenuItems, { Sub menu messages }
1..MaxSubMenuItems] of ShortStr;
SubMenuLtr: Array[1..MaxMenuItems, { Sub menu 1st letter }
1..MaxSubMenuItems] of Char;
MenuOfs : Array[1..MaxMenuItems] of Integer; { Offset of main menu }
NumPicks : Integer; { Number of main picks }
NumSubs : Array[1..MaxMenuItems] of Integer; { Number of sub picks }
Longest : Array[1..MaxMenuItems] of Integer; { longest string in subs }
Pick : Integer; { Current main pick }
LastPick : Integer; { Last main pick }
XP1,YP1 : Integer; { top left of submenu location }
XP2,YP2 : Integer; { bottom right of submenu location }
SPick : Integer; { Current submenu pick }
LastSPick : Integer; { Last submenu pick }
WorkScreen : Screen; { Used to save screen contents -- see IOStuff }
MenuScreen : Screen; { Used to save screen contents -- see IOStuff }
RebuildMenu : Boolean; { Switch to rebuild menu over new screen }
JustWroteSub: Boolean; { Switch to skip rewriting submenu }
FirstTime : Boolean; { Used to skip some cleanup logic first time thru }
{============================================================================}
PROCEDURE RestoreWorkScreen;
{ Restores the working screen to its appearance at the last SaveWorkScreen }
BEGIN
If Color then MoveToScreen(WorkScreen,CS,4000)
else Move(WorkScreen,MS,4000);
END;
{============================================================================}
PROCEDURE SaveWorkScreen;
{ Saves a new working screen. Should be called in the main program }
{ any time you fiddle with the screen and want to save it }
BEGIN
If Color then MoveFromScreen(CS,WorkScreen,4000)
else Move(MS,WorkScreen,4000);
JustWroteSub := false; { set these switches to rebuild menu }
RebuildMenu := true;
END;
{============================================================================}
PROCEDURE RestoreMenuScreen;
{ Used to save the contents of the screen after the main menu line written }
BEGIN
If Color then MoveToScreen(MenuScreen,CS,4000)
else Move(MenuScreen,MS,4000);
END;
{============================================================================}
PROCEDURE SaveMenuScreen;
{ Restores the screen to its appearance after the main menu line written }
BEGIN
If Color then MoveFromScreen(CS,MenuScreen,4000)
else Move(MS,MenuScreen,4000);
END;
{============================================================================}
PROCEDURE RebuildIt;
{ Flips the switches that trigger a complete rebuild of menus }
{ This is more efficient when you don't care if the screen is saved }
BEGIN
JustWroteSub := false; { set these switches to rebuild menu }
RebuildMenu := true;
END;
{============================================================================}
PROCEDURE SetMain(MenuStr:AnyStr);
{ This Procedure sets the main (bar) menu. Menu contents are contained in }
{ string MenuStr and are delimited by an /. Don't forget the last / }
VAR
CPos : Integer; { Parsing variables }
Len,II : Integer;
SaveAttr : Byte;
BEGIN
SaveAttr := TextAttr; { Save the colors }
Pick := 1; { 1st pick }
LastPick := 1;
CPos := 1;
NumPicks := 0;
FirstTime := true;
SaveWorkScreen; { Save the screen for restoration later }
{ SaveWorkScreen also triggers rebuild }
Repeat { Parse the main menu string }
If NumPicks < MaxMenuItems then NumPicks := NumPicks + 1;
{ Find next substring delimited by an / }
Len := Pos('/',Copy(MenuStr,CPos,Length(MenuStr)+1-CPos))-1;
{ copy the substring into menu message array }
MenuMsg[NumPicks] := Copy(MenuStr,CPos,Len);
{ get the first letter of the menu message }
MenuLtr[NumPicks] := UpCase(MenuMsg[NumPicks,1]);
{ Calc menu offset. Sp is pad spaces between picks}
MenuOfs[NumPicks] := CPos+Sp*(NumPicks);
NumSubs[NumPicks] := 0; {Initialize number of sub picks under this pick }
CPos := CPos+Len+1; { move parsing position to next substring }
Until CPos >= Length(MenuStr);
TextAttr := SaveAttr; { restore colors }
END;
{============================================================================}
PROCEDURE SetSub(Sub:Integer;SubStr:LongStr);
{ This Procedure sets the sub menu. Menu contents are contained in }
{ string SubStr and are delimited by an /. Don't forget the last /. }
{ Variable Sub is the number of the main menu the SubStr goes with }
VAR
CPos,P,Len : Integer;
BEGIN
CPos := 1; { Initialization }
NumSubs[Sub] := 0;
Longest[Sub] := 0;
Repeat { String Parsing loop }
{ First increment the number of menu picks }
If NumSubs[Sub] < MaxMenuItems then NumSubs[Sub] := NumSubs[Sub] + 1;
{ Get the next substring delimited by a / }
Len := Pos('/',Copy(SubStr,CPos,Length(SubStr)+1-CPos))-1;
{ Copy the substring into the menu message }
SubMenuMsg[Sub,NumSubs[Sub]] := Copy(SubStr,CPos,Len);
{ Get the first letter }
SubMenuLtr[Sub,NumSubs[Sub]] := UpCase(SubMenuMsg[Sub,NumSubs[Sub],1]);
{ Remember the longest string length for padding later }
If Length(SubMenuMsg[Sub,NumSubs[Sub]]) > Longest[Sub]
then Longest[Sub] := Length(SubMenuMsg[Sub,NumSubs[Sub]]);
CPos := CPos+Len+1; { Move parsing position to next string }
Until CPos >= Length(SubStr); { End of parsing loop }
For P := 1 to NumSubs[Sub] do Begin { pad all strings to same length }
Len := Length(SubMenuMsg[Sub,P]);
FillChar(SubMenuMsg[Sub,P,Len+1],Longest[Sub]-Len,' '); { Pad with blanks }
SubMenuMsg[Sub,P,0] := Chr(Longest[Sub]); { reset length }
End;
SPick := 1; { Initialize submenu pick index here }
LastSPick := 1;
END;
{============================================================================}
PROCEDURE WriteSub(Sub:Integer);
{ This Procedure writes out the submenu }
VAR
II : Integer;
SaveAttr : Byte;
BEGIN
If NumSubs[Sub] = 0 then exit;
SaveAttr := TextAttr; { Save the color attributes }
XP1 := XPos+MenuOfs[Sub];
YP1 := YPos+2;
XP2 := XPos+MenuOfs[Sub]+Longest[Sub]+1;
YP2 := YPos+NumSubs[Sub]+1;
SavePartScreen(XP1-1,YP1-1,XP2+1,YP2+1);
{ Draw a single line border }
SetColor(ColorF4,ColorB4);
SBorder(XP1-1,YP1-1,XP2+1,YP2+1,'');
For II := 1 to NumSubs[Sub] do begin { Write the menu messages }
SetColor(ColorF1,ColorB1);
WriteSt(' '+SubMenuMsg[Sub,II]+' ',XP1,YP1+II-1);
SetColor(ColorF2,ColorB2);
WriteCh(SubMenuLtr[Sub,II],XP1+1,YP1+II-1);
End;
TextAttr := SaveAttr; { Restore the color attributes }
END;
{============================================================================}
PROCEDURE WriteMain;
{ This Procedure writes out the main menu }
VAR
II : Integer;
SaveAttr : Byte;
BEGIN
SaveAttr := TextAttr; { Save the color attributes }
SetColor(ColorF1,ColorB1);
GoToXY(1,YPos);ClrEol; { Clear the menu line }
For II := 1 to NumPicks do begin { Write the menu messages }
SetColor(ColorF1,ColorB1);
WriteSt(MenuMsg[II],XPos+MenuOfs[II],YPos); { Write Picks }
SetColor(ColorF2,ColorB2);
WriteCh(MenuLtr[II],XPos+MenuOfs[II],YPos); { Write 1st letter }
End;
SaveMenuScreen; { Save the screen image }
TextAttr := SaveAttr;
END;
{============================================================================}
FUNCTION PickSub(Sub : Integer) : Char;
{ This Function plays with the submenu and returns the first character }
{ of the selected menu item }
CONST
UpArrow = #72; { Keystrokes used }
Downarrow = #80;
EnterKey = #13;
EscKey = #27;
Abort = #0;
VAR
II : Integer; { General purpose loop index }
Ch : Char; { Keystroke character }
SubExit : Boolean; { Exit switch }
BeepOn : Boolean;
FunctKey : Boolean; { True if dey is function key }
ExitCond : Integer; { Used for different exit conditions }
SaveAttr : Byte; { Color attributes }
BEGIN
SaveAttr := TextAttr; { Save the current colors }
HideCursor; { Hide the cursor }
SubExit := False; { Initialze exit switch }
ExitCond := 1;
If (SPick < 1) or (SPick > NumSubs[Sub]) then SPick := 1;
If (LastSPick < 1) or (LastSPick > NumSubs[Sub]) then LastSPick := 1;
If not JustWroteSub then begin
If RebuildMenu then begin
If not FirstTime then RestoreWorkScreen;
WriteMain; { Reconstruct the main menu }
SetColor(ColorF3,ColorB3);
{ Rewrite active main menu pick in reverse }
WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
WriteSub(Pick); { Reconstruct the submenu }
RebuildMenu := false;
End
else begin
RestoreMenuScreen;
SetColor(ColorF3,ColorB3);
{ Rewrite active main menu pick in reverse }
WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
WriteSub(Pick); { Reconstruct the submenu }
End;
End;
FirstTime := False;
JustWroteSub := False;
SetColor(ColorF3,ColorB3);
{ Rewrite active sub menu pick in reverse }
WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
LastSPick := SPick;
Repeat { Main keystroke reading loop -- continue until enter or escape }
If SPick <> LastSPick then Begin
{ First restore the last pick }
SetColor(ColorF1,ColorB1);
WriteSt(' '+SubMenuMsg[Sub,LastSPick]+' ',XPos+MenuOfs[Sub],YPos+LastSPick+1);
SetColor(ColorF2,ColorB2);
WriteCh(SubMenuLtr[Sub,LastSPick],XPos+MenuOfs[Sub]+1,YPos+LastSPick+1);
{ Highlight new pick in reverse }
SetColor(ColorF3,ColorB3);
WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
LastSPick := SPick; { Set last pick to current pick }
End;
Ch := Readkey; { Read a key }
If Ch <> #0 then FunctKey := False else
Begin
Ch := ReadKey;
FunctKey := True;
End;
If not FunctKey then Case Ch of { Handle non function keys here }
#32..#125: Begin { Check input char against 1st letters }
BeepOn := True;
For II := 1 to NumSubs[Sub] do Begin
{ got a match }
If UpCase(Ch) = SubMenuLtr[Sub,II] then Begin
SPick := II; { Set pick index to the matched char }
SubExit := True; { Turn on exit switch }
BeepOn := False;
End;
End;
If BeepOn then Beep; { You hit a bad character }
End;
EnterKey : Begin { Ordinary exit }
ExitCond := 1;
SubExit := true;
End;
EscKey : Begin { Abort exit }
ExitCond := 2;
SPick := 0;
SubExit := true;
End;
End; {case not functkey}
If FunctKey then Case Ch of { Handle function keys here }
UpArrow : SPick := Pred(SPick); { Move up one }
DownArrow : SPick := Succ(SPick); { Move down one }
Else Beep;
End; {case functkey}
If SPick > NumSubs[Sub] then SPick := 1; { Make sure Pick in bounds }
If SPick < 1 then Begin { User exited with up arrow }
ExitCond := 2; { Handle like abort }
SubExit := true;
End;
Until SubExit; { Bottom of big key reading loop }
SetColor(ColorF1,ColorB1); { Restore last pick on submenu }
WriteSt(' '+SubMenuMsg[Sub,LastSPick]+' ',XPos+MenuOfs[Sub],YPos+LastSPick+1);
SetColor(ColorF2,ColorB2);
WriteCh(SubMenuLtr[Sub,LastSPick],XPos+MenuOfs[Sub]+1,YPos+LastSPick+1);
Case ExitCond of
2: Begin
PickSub := Abort;
JustWroteSub := true;
End;
1: Begin
PickSub := SubMenuLtr[Sub,SPick]; {set function to letter }
{ Highlight new pick in reverse }
SetColor(ColorF3,ColorB3);
WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
JustWroteSub := false;
End;
End; {case}
{ Clean up and get out }
ShowCursor;
TextAttr := SaveAttr; { Restore colors }
End;
{============================================================================}
FUNCTION PickMain : Char;
{ This Function returns the first character of the main menu item }
{ the user selected }
CONST
LeftArrow = #75; { Keystrokes used }
RightArrow = #77;
DownArrow = #80;
EnterKey = #13;
EscKey = #27;
Abort = #0;
VAR
II : Integer; { General purpose loop index }
Ch : Char; { Keystroke read in }
MainExit : Boolean; { Exit switch }
BeepOn : Boolean;
FunctKey : Boolean; { True if input char is a function key }
SaveAttr : Byte; { Save color attributes }
BEGIN
SaveAttr := TextAttr; { Initialization }
MainExit := False;
HideCursor;
If (Pick < 1) or (Pick > NumPicks) then Pick := 1;
If Not JustWroteSub then begin
If RebuildMenu then begin
RestoreWorkScreen;
WriteMain; { Reconstruct the main menu }
SetColor(ColorF3,ColorB3);
{ Rewrite active main menu pick in reverse }
WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
WriteSub(Pick); { Reconstruct the submenu }
RebuildMenu := false;
End
else begin
RestoreMenuScreen;
SetColor(ColorF3,ColorB3);
{ Rewrite active main menu pick in reverse }
WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
WriteSub(Pick); { Reconstruct the submenu }
End;
End;
Repeat { main keystroke loop }
Ch := Readkey;
If Ch <> #0 then FunctKey := False else
Begin
Ch := ReadKey;
FunctKey := True;
End;
If not FunctKey then Case Ch of
#32..#125: Begin
BeepOn := True;
For II := 1 to NumPicks do Begin
If UpCase(Ch) = UpCase(MenuLtr[II]) then Begin
Pick := II;
MainExit := True;
BeepOn := False;
End;
End;
If BeepOn then Beep;
End;
EnterKey,
EscKey : MainExit := True;
End; {case not functkey}
If FunctKey then Case Ch of
LeftArrow : Pick := Pred(Pick);
RightArrow : Pick := Succ(Pick);
DownArrow : If NumSubs[Pick] > 0 then MainExit := true else beep;
Else Beep;
End; {case functkey}
If Pick > NumPicks then Pick := 1;
If Pick < 1 then Pick := NumPicks;
If Pick <> LastPick then Begin
SetColor(ColorF1,ColorB1);
WriteSt(' '+MenuMsg[LastPick]+' ',XPos+MenuOfs[LastPick]-1,YPos); { Write Picks }
SetColor(ColorF2,ColorB2);
WriteCh(MenuLtr[LastPick],XPos+MenuOfs[LastPick],YPos); { Write 1st letter }
If NumSubs[LastPick] > 0 then RestorePartScreen(XP1-1,YP1-1,XP2+1,YP2+1);
SetColor(ColorF3,ColorB3);
WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos); { Write a new pick }
WriteSub(Pick);
LastPick := Pick;
End;
Until MainExit;
If Ch = EscKey then PickMain := Abort
else PickMain := MenuLtr[Pick];
JustWroteSub := true;
SPick := 1;
LastSPick := 1;
ShowCursor;
TextAttr := SaveAttr;
End;
END. {of unit}
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/