home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
GEMini Atari
/
GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso
/
files
/
bbs
/
pibterm
/
pibt3sp3
/
pibmenus.pas
next >
Wrap
Pascal/Delphi Source File
|
1985-09-04
|
46KB
|
967 lines
(*----------------------------------------------------------------------*)
(* PIBMENUS.PAS --- Menu Routines for Turbo Pascal *)
(*----------------------------------------------------------------------*)
(* *)
(* Author: Philip R. Burns *)
(* *)
(* Date: Version 1.0: January, 1985 *)
(* Version 1.1: March, 1985 *)
(* Version 1.2: May, 1985 *)
(* Version 2.0: June, 1985 *)
(* Version 2.1: July, 1985 *)
(* *)
(* Systems: For MS-DOS on IBM PCs and close compatibles only. *)
(* Note: I have checked these on Zenith 151s under *)
(* MSDOS 2.1 and IBM PCs under PCDOS 2.0. *)
(* *)
(* History: These routines represent my substantial upgrading of the *)
(* simple menu routines written by Barry Abrahamsen which *)
(* I believe appeared originally in the TUG newsletter. *)
(* The windowing facility provides windows similar to those *)
(* implemented in QMODEM by John Friel III. *)
(* *)
(* Version 2.0 of these adds the exploding windows feature *)
(* as well the use-selectable box-drawing characters. *)
(* The exploding box algorithm is derived from one by *)
(* Jim Everingham. *)
(* *)
(* Note that the routines present in PIBSCREN.PAS were *)
(* originally part of the PIBMENUS.PAS file. With version *)
(* 2.0 of PibMenus, PIBMENUS.PAS is split into the screen- *)
(* handling routines in PIBSCREN.PAS and the actual menu *)
(* routines in PIBMENUS.PAS. *)
(* *)
(* Suggestions for improvements or corrections are welcome. *)
(* Please leave messages on Gene Plantz's BBS (312) 882 4145 *)
(* or Ron Fox's BBS (312) 940 6496. *)
(* *)
(* If you use this code in your own programs, please be nice *)
(* and give all of us credit. *)
(* *)
(*----------------------------------------------------------------------*)
(* *)
(* Needs: These routines need the include files MINMAX.PAS, *)
(* GLOBTYPE.PAS, ASCII.PAS, and PIBSCREN.PAS. These files *)
(* are not included here, since Turbo Pascal regrettably does *)
(* not allow nested includes. *)
(* *)
(*----------------------------------------------------------------------*)
(* *)
(* What these routines do: *)
(* *)
(* These routines provide a straight-forward menu-selection *)
(* facility, similar to that used in programs like Lotus. A pop-up *)
(* window holds the menu. The menu is contained in a frame. The *)
(* items are displayed within the frame. The currently selected *)
(* item is highlighted in reverse video. You move up and down in *)
(* the list of menu items by using the up and down arrow keys, or *)
(* the space bar. To make a selection, hit the Enter (Return) key. *)
(* *)
(* Alternatively, you may hit the first character of a menu item. *)
(* The first menu item found with that initial letter is selected. *)
(* *)
(* The characters comprising the menu box are user-selectable. *)
(* In addition, menus may just "pop up" onto the screen, or may *)
(* "explode" onto the screen. *)
(* *)
(*----------------------------------------------------------------------*)
(* *)
(* Use: *)
(* *)
(* (1) Define a variable of type Menu_Type, say, MYMENU. *)
(* *)
(* (2) Define the following entries in MYMENU: *)
(* *)
(* Menu_Size --- Number of entries in this menu *)
(* Menu_Title --- Title for the menu *)
(* Menu_Row --- Row where menu should appear (upper LHC *)
(* Menu_Column --- Column where menu should appear *)
(* Menu_Width --- Width of menu *)
(* Menu_Height --- Height of menu *)
(* Menu_Default --- Ordinal of the default menu entry *)
(* Menu_Tcolor --- Color to display menu text *)
(* Menu_Bcolor --- Color for menu background *)
(* Menu_Fcolor --- Color for menu frame box *)
(* *)
(* (3) Now for each of Menu_Size Menu_Entries, define: *)
(* Menu_Text --- Text of menu item *)
(* *)
(* (4) Optionally call Menu_Set_Box_Chars to define the *)
(* characters used to form the menu box. *)
(* *)
(* (5) Optionally call Menu_Set_Explode to set the menus as either *)
(* exploding or pop-up. *)
(* *)
(* (6) Optionally call Menu_Set_Beep to turn beeping on/off. *)
(* *)
(* (7) Call Menu_Display_Choices to display menu. The default *)
(* menu choice will be highlighted. *)
(* *)
(* (8) Call Menu_Get_Choice to retrieve menu choice. The up and *)
(* down arrows, and the space bar, can be used to move *)
(* through the menu items. Each item is highlighted in turn. *)
(* Whichever item is highlighted when a carriage return is *)
(* entered is returned as the chosen item. *)
(* *)
(* Note the the routine Set_Turbo_Version need not be called any *)
(* longer, thanks to a version-independent fix suggested by *)
(* Mike Harrington. *)
(* *)
(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)
(* Menu constants, types, and variables *)
(*----------------------------------------------------------------------*)
CONST
Up_arrow = ^E; (* move up in menu code *)
Down_arrow = ^X; (* move down in menu code *)
Space_bar = #32; (* space bar *)
Ch_cr = #13; (* Carriage return *)
Ch_esc = #27; (* Escape *)
Ch_bell = #07; (* Bell *)
Max_Menu_Items = 18; (* Maximum number of menu choices *)
Dont_Erase_Menu = FALSE;
Erase_Menu = TRUE;
TYPE
String40 = STRING[40] (* Menu entry string type *);
String60 = STRING[60] (* Menu title string type *);
Menu_Entry = RECORD
Menu_Item_Text : String40; (* Text of entry *)
Menu_Item_Row : BYTE; (* Row position of menu item *)
Menu_Item_Column : BYTE; (* Column position of menu item *)
END;
Menu_Type = RECORD
Menu_Size : 1 .. Max_Menu_Items; (* No. of items in menu *)
Menu_Title : String60; (* Menu title *)
Menu_Row : BYTE; (* Row position of menu *)
Menu_Column : BYTE; (* Column position of menu *)
Menu_Width : BYTE; (* Width of menu *)
Menu_Height : BYTE; (* Height of menu *)
Menu_Default : 1 .. Max_Menu_Items; (* Default value position *)
Menu_TColor : BYTE; (* Foreground text color *)
Menu_BColor : BYTE; (* BackGround color *)
Menu_FColor : BYTE; (* Frame color *)
(* Menu items themselves *)
Menu_Entries : ARRAY[ 1 .. Max_Menu_Items ] Of Menu_Entry;
END;
(* STRUCTURED *) CONST
Menu_Explode_Mode : BOOLEAN (* TRUE to use exploding menus *)
= FALSE;
Menu_Beep_Mode : BOOLEAN (* TRUE to beep on errors *)
= TRUE;
(* STRUCTURED *) CONST
(* Box-drawing characters for menus *)
Menu_Box_Chars : RECORD
Top_Left_Corner : CHAR;
Top_Line : CHAR;
Top_Right_Corner : CHAR;
Right_Line : CHAR;
Bottom_Right_Corner : CHAR;
Bottom_Line : CHAR;
Bottom_Left_Corner : CHAR;
Left_Line : CHAR;
END
=
( Top_Left_Corner : 'ר';
Top_Line : 'ל';
Top_Right_Corner : 'Õ';
Right_Line : 'ø';
Bottom_Right_Corner : '®';
Bottom_Line : 'ל';
Bottom_Left_Corner : 'ק';
Left_Line : 'ø' );
(*----------------------------------------------------------------------*)
(* Menu_Set_Explode --- Set explode mode on or off *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_Set_Explode( Explode_ON : BOOLEAN );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_Set_Explode *)
(* *)
(* Purpose: Turn exploding menus on or off *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_Set_Explode( Explode_ON : BOOLEAN ); *)
(* *)
(* Explode_ON --- TRUE to use exploding menus, *)
(* FALSE to use pop-up menus *)
(* *)
(* Calls: None *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Menu_Set_Explode *)
Menu_Explode_Mode := Explode_ON;
END (* Menu_Set_Explode *);
(*----------------------------------------------------------------------*)
(* Menu_Set_Beep --- Set beep mode on or off *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_Set_Beep( Beep_ON : BOOLEAN );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_Set_Beep *)
(* *)
(* Purpose: Turn beeping (errors, etc.) on or off *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_Set_Beep( Beep_ON : BOOLEAN ); *)
(* *)
(* Beep_ON --- TRUE to allow beeps, *)
(* FALSE to disallow beeps. *)
(* *)
(* Calls: None *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Menu_Set_Beep *)
Menu_Beep_Mode := Beep_ON;
END (* Menu_Set_Beep *);
(*----------------------------------------------------------------------*)
(* Menu_Set_Box_Chars --- Set box drawing characters for menus *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_Set_Box_Chars( Top_Left_Corner : CHAR;
Top_Line : CHAR;
Top_Right_Corner : CHAR;
Right_Line : CHAR;
Bottom_Right_Corner : CHAR;
Bottom_Line : CHAR;
Bottom_Left_Corner : CHAR;
Left_Line : CHAR );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_Set_Box_Chars *)
(* *)
(* Purpose: Set box characters for drawing menu boxes *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_Set_Box_Chars( Top_Left_Corner : CHAR; *)
(* Top_Line : CHAR; *)
(* Top_Right_Corner : CHAR; *)
(* Right_Line : CHAR; *)
(* Bottom_Right_Corner : CHAR; *)
(* Bottom_Line : CHAR; *)
(* Bottom_Left_Corner : CHAR; *)
(* Left_Line : CHAR ); *)
(* *)
(* --- arguments are what their names suggest. *)
(* *)
(* *)
(* Calls: None *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Menu_Set_Box_Chars *)
Menu_Box_Chars.Top_Left_Corner := Top_Left_Corner;
Menu_Box_Chars.Top_Line := Top_Line;
Menu_Box_Chars.Top_Right_Corner := Top_Right_Corner;
Menu_Box_Chars.Right_Line := Right_Line;
Menu_Box_Chars.Bottom_Right_Corner := Bottom_Right_Corner;
Menu_Box_Chars.Bottom_Line := Bottom_Line;
Menu_Box_Chars.Bottom_Left_Corner := Bottom_Left_Corner;
Menu_Box_Chars.Left_Line := Left_Line;
END (* Menu_Set_Box_Chars *);
(*----------------------------------------------------------------------*)
(* Draw_Menu_Frame --- Draw a Frame *)
(*----------------------------------------------------------------------*)
PROCEDURE Draw_Menu_Frame( UpperLeftX, UpperLeftY,
LowerRightX, LowerRightY : INTEGER;
Frame_Color, Title_Color : INTEGER;
Menu_Title: AnyStr );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Draw_Menu_Frame *)
(* *)
(* Purpose: Draws a titled frame using PC graphics characters *)
(* *)
(* Calling Sequence: *)
(* *)
(* Draw_Menu_Frame( UpperLeftX, UpperLeftY, *)
(* LowerRightX, LowerRightY, *)
(* Frame_Color, Title_Color : INTEGER; *)
(* Menu_Title: AnyStr ); *)
(* *)
(* UpperLeftX, UpperLeftY --- Upper left coordinates *)
(* LowerRightX, LowerRightY --- Lower right coordinates *)
(* Frame_Color --- Color for frame *)
(* Title_Color --- Color for title text *)
(* Menu_Title --- Menu Title *)
(* *)
(* Calls: GoToXY *)
(* Window *)
(* ClrScr *)
(* Dupl *)
(* Draw_Box (internal) *)
(* Do_Explosion (internal) *)
(* *)
(* Remarks: *)
(* *)
(* The area inside the frame is cleared after the frame is *)
(* drawn. If a box without a title is desired, enter a null *)
(* string for a title. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
I : INTEGER;
L : INTEGER;
LT : INTEGER;
XM : INTEGER;
YM : INTEGER;
XS : INTEGER;
YS : INTEGER;
R : REAL;
X1 : INTEGER;
X2 : INTEGER;
Y1 : INTEGER;
Y2 : INTEGER;
XM1: INTEGER;
YM1: INTEGER;
Knt: INTEGER;
(*----------------------------------------------------------------------*)
PROCEDURE Draw_Box( X1, Y1, X2, Y2 : INTEGER;
Frame_Color : INTEGER;
Title_Color : INTEGER;
Title : AnyStr );
VAR
I : INTEGER;
LT : INTEGER;
BEGIN (* Draw_Box *)
Window( 1, 1, 80, 25 );
LT := LENGTH( Title );
IF LT > 0 THEN
BEGIN
WriteSXY( Menu_Box_Chars.Top_Left_Corner + '[ ',
X1, Y1, Frame_Color );
WriteSXY( Title, X1 + 3, Y1, Title_Color );
WriteSXY( ' ]', X1 + LT + 3, Y1, Frame_Color );
END
ELSE
WriteSXY( Menu_Box_Chars.Top_Left_Corner +
DUPL( Menu_Box_Chars.Top_Line , 4 ), X1, Y1, Frame_Color );
(* Draw remainder of top of frame *)
FOR I := ( X1 + LT + 5 ) TO ( X2 - 1 ) DO
WriteCXY( Menu_Box_Chars.Top_Line, I, Y1, Frame_Color );
WriteCXY( Menu_Box_Chars.Top_Right_Corner, X2, Y1, Frame_Color );
(* Draw sides of frame *)
FOR I := ( Y1 + 1 ) TO ( Y2 - 1 ) DO
BEGIN
WriteCXY( Menu_Box_Chars.Left_Line, X1, I, Frame_Color );
WriteCXY( Menu_Box_Chars.Right_Line, X2, I, Frame_Color );
END;
(* Draw bottom of frame *)
WriteCXY( Menu_Box_Chars.Bottom_Left_Corner, X1, Y2, Frame_Color );
FOR I := ( X1 + 1 ) TO ( X2 - 1 ) DO
WriteCXY( Menu_Box_Chars.Bottom_Line, I, Y2, Frame_Color );
WriteCXY( Menu_Box_Chars.Bottom_Right_Corner, X2, Y2, Frame_Color );
END (* Draw_Box *);
(*----------------------------------------------------------------------*)
PROCEDURE Do_Explosion;
(*----------------------------------------------------------------------*)
(* --- Basic algorithm by Jim Everingham --- *)
(*----------------------------------------------------------------------*)
BEGIN (* Do_Explosion *)
XM := UpperLeftX + L DIV 2;
YM := UpperLeftY + ( LowerRightY - UpperLeftY ) DIV 2;
X1 := UpperLeftX;
X2 := LowerRightX;
Y1 := UpperLeftY;
Y2 := LowerRightY;
XM1 := XM;
YM1 := YM;
(* Figure out increments for *)
(* increasing boz dimensions *)
(* to produce explosion. *)
IF ( XM > YM ) THEN
Knt := TRUNC( L / 2 )
ELSE
Knt := TRUNC( ( Y2 - Y1 ) / 2 );
Y1 := Y1 - 1;
Y2 := Y2 - 1;
X1 := X1 + 1;
X2 := X2 - 1;
(* Draw series of increasing *)
(* size boxes, giving appearance *)
(* that box "explodes" from its *)
(* center. *)
FOR I := 1 TO ROUND( Knt / 3 ) DO
BEGIN
(* Adjust sides *)
IF ( XM > ( X1 - 2 ) ) THEN
XM := XM - 3
ELSE IF ( XM > ( X1 - 1 ) ) THEN
XM := XM - 2
ELSE IF ( XM > X1 ) THEN
XM := XM - 1;
IF ( XM1 < ( X2 + 2 ) ) THEN
XM1 := XM1 + 3
ELSE IF ( XM1 < ( X2 + 1 ) ) THEN
XM1 := XM1 + 2
ELSE IF ( XM1 < X2 ) THEN
XM1 := XM1 + 1;
(* Adjust top and bottom *)
IF ( YM > ( Y1 + 2 ) ) THEN
YM := YM - 3
ELSE IF ( YM > ( Y1 + 1 ) ) THEN
YM := YM - 2
ELSE IF ( YM > Y1 ) THEN
YM := YM - 1;
IF ( YM1 < ( Y2 - 2 ) ) THEN
YM1 := YM1 + 3
ELSE IF ( YM1 < ( Y2 - 1 ) ) THEN
YM1 := YM1 + 2
ELSE IF ( YM1 < Y2 ) THEN
YM1 := YM1 + 1;
(* Define new window *)
WINDOW( XM + 1, YM + 1, XM1, YM1 );
(* Clear it out *)
Clear_Window;
(* Draw box *)
Draw_Box( XM+1, YM+1, XM1, YM1, Frame_Color, Title_Color, '' );
END (* For *);
END (* Do_Explosion *);
(*----------------------------------------------------------------------*)
BEGIN (* Draw_Menu_Frame *)
L := LowerRightX - UpperLeftX;
LT := LENGTH( Menu_Title );
(* Adjust title length if necessary *)
IF LT > ( L - 5 ) THEN Menu_Title[0] := CHR( L - 5 );
(* Get explosion if requested *)
IF Menu_Explode_Mode THEN Do_Explosion;
(* Display actual menu frame *)
Draw_Box( UpperLeftX, UpperLeftY, LowerRightX, LowerRightY,
Frame_Color, Title_Color, Menu_Title );
(* Establish scrolling window area *)
Window( UpperLeftX+1, UpperLeftY+1, LowerRightX-1, LowerRightY-1 );
(* Clear out the window area *)
(* KLUDGE NOTE: ClrScr doesn't *)
(* seem to work correctly on mono *)
(* screens with Turbo 3.0 in the *)
(* context of PibTerm. *)
(*
ClrScr;
*)
FOR I := 1 TO ( LowerRightY - UpperLeftY - 1 ) DO
BEGIN
GoToXY( 1 , I );
ClrEol;
END;
GoToXY( 1 , 1 );
(* Ensure proper color for text *)
TextColor( Title_Color );
END (* Draw_Menu_Frame *);
(*----------------------------------------------------------------------*)
(* Menu_Click --- Make short click noise *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_Click;
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_Click *)
(* *)
(* Purpose: Clicks Terminal Bell *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_Click; *)
(* *)
(* Calls: Sound *)
(* Delay *)
(* NoSound *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Menu_Click *)
IF Menu_Beep_Mode THEN
BEGIN
Sound( 2000 );
DELAY( 10 );
NoSound;
END;
END (* Menu_Click *);
(*----------------------------------------------------------------------*)
(* Menu_Beep --- Ring Terminal Bell *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_Beep;
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_Beep *)
(* *)
(* Purpose: Rings Terminal Bell *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_Beep; *)
(* *)
(* Calls: None *)
(* *)
(* Remarks: *)
(* *)
(* If Menu_Beep_Mode is FALSE, then '<ALERT>' is displayed in *)
(* blinking characters on line 25 for 1 second. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
I : BYTE;
J : BYTE;
Save_C25 : PACKED ARRAY[1..7] OF CHAR;
Save_A25 : PACKED ARRAY[1..7] OF INTEGER;
BEGIN (* Menu_Beep *)
(* Generate beep if beep mode on *)
IF Menu_Beep_Mode THEN
WRITE( Ch_Bell )
ELSE (* Else generate blinking error *)
BEGIN
(* Line 25, Column 36 *)
J := 3913;
(* Save character, attribute *)
FOR I := 1 TO 7 DO
WITH Actual_Screen^ DO
BEGIN
Save_C25[I] := CHR( Screen_Image[ J ] );
Save_A25[I] := Screen_Image[ J + 1 ];
J := J + 2;
END;
(* Display blinking error indicator *)
WriteSXY( '<ALERT>', 36, 25, WHITE + BLINK );
DELAY( 1000 );
(* Restore previous text *)
FOR I := 1 TO 7 DO
WriteCXY( Save_C25[I], 35 + I, 25, Save_A25[I] );
END;
END (* Menu_Beep *);
(*----------------------------------------------------------------------*)
(* Menu_Turn_On --- Highlight Menu Choice *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_Turn_On( Menu: Menu_Type; Menu_Item : INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_Turn_On *)
(* *)
(* Purpose: Highlight a menu item using reverse video *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_Turn_On( Menu: Menu_Type; Menu_Item : INTEGER ); *)
(* *)
(* Menu : Menu containing item to highlight *)
(* Menu_Item : Menu entry to highlight *)
(* *)
(* Calls: GoToXY *)
(* RvsVideoOn *)
(* RvsVideoOff *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Menu_Turn_On *)
WITH Menu.Menu_Entries[ Menu_Item ] DO
BEGIN
GoToXY( Menu_Item_Column, Menu_Item_Row );
RvsVideoOn( Menu.Menu_Tcolor, Menu.Menu_Bcolor );
WRITE( Menu_Item_Text );
RvsVideoOff( Menu.Menu_Tcolor, Menu.Menu_Bcolor );
END;
END (* Menu_Turn_On *);
(*----------------------------------------------------------------------*)
(* Menu_Turn_Off --- UnHighlight Menu Choice *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_Turn_Off( Menu: Menu_Type; Menu_Item : INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_Turn_Off *)
(* *)
(* Purpose: Removes highlighting from menu item *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_Turn_Off( Menu : Menu_Type; Menu_Item : INTEGER ); *)
(* *)
(* Menu : Menu containing item to unhighlight *)
(* RvsVideoOff : Menu entry to un-highlight *)
(* *)
(* Calls: GoToXY *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Menu_Turn_Off *)
WITH Menu.Menu_Entries[ Menu_Item ] DO
BEGIN
GoToXY( Menu_Item_Column , Menu_Item_Row );
RvsVideoOff( Menu.Menu_Tcolor, Menu.Menu_Bcolor );
WRITE( Menu_Item_Text );
END;
END (* Menu_Turn_Off *);
(*----------------------------------------------------------------------*)
(* Menu_IBMCh --- Interpret IBM keyboard chars. *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_IBMCh( VAR C : CHAR );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_IBMCh *)
(* *)
(* Purpose: Interpret IBM keyboard chars. *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_IBMCh( Var C : Char ); *)
(* *)
(* C --- On input, char following escape; *)
(* on output, char revised to Wordstar command code. *)
(* *)
(* Calls: None *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Menu_IBMCh *)
READ( Kbd , C );
CASE C OF
'H' : C := Up_arrow;
'P' : C := Down_arrow;
ELSE;
END;
END (* Menu_IBMCh *);
(*----------------------------------------------------------------------*)
(* Menu_Display_Choices --- Display Menu Choices *)
(*----------------------------------------------------------------------*)
PROCEDURE Menu_Display_Choices( Menu : Menu_Type );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Menu_Display_Choices *)
(* *)
(* Purpose: Displays Menu Choices *)
(* *)
(* Calling Sequence: *)
(* *)
(* Menu_Display_Choices( Menu : Menu_Type ); *)
(* *)
(* Menu --- Menu record to be displayed. *)
(* *)
(* Calls: ClsScr *)
(* GoToXY *)
(* Draw_Menu_Frame *)
(* Save_Screen *)
(* *)
(*----------------------------------------------------------------------*)
VAR
I : INTEGER;
J : INTEGER;
XL : INTEGER;
YL : INTEGER;
XR : INTEGER;
YR : INTEGER;
MaxX : INTEGER;
MaxY : INTEGER;
BEGIN (* Menu_Display_Choices *)
(* Establish menu size *)
XL := Menu.Menu_Column;
YL := Menu.Menu_Row;
XR := LENGTH( Menu.Menu_Title ) + XL - 1;
YR := YL;
MaxX := Menu.Menu_Width;
MaxY := Menu.Menu_Height;
FOR I := 1 TO Menu.Menu_Size DO
WITH Menu.Menu_Entries[I] DO
BEGIN
IF Menu_Item_Row > MaxY THEN MaxY := Menu_Item_Row;
J := LENGTH( Menu_Item_Text ) + Menu_Item_Column - 1;
IF J > MaxX THEN MaxX := J;
END;
J := XL + MaxX - 1;
IF J > XR THEN XR := J;
J := YL + MaxY - 1;
IF J > YR THEN YR := J;
XL := XL - 4;
IF XL < 0 THEN XL := 0;
YL := YL - 1;
IF YL < 0 THEN YL := 0;
YR := YR + 1;
IF YR > 25 THEN YR := 25;
IF XR > 80 THEN XR := 80;
(* Save current screen image *)
(* if not already saved *)
IF Current_Saved_Screen > 0 THEN
BEGIN
IF Saved_Screen_List[ Current_Saved_Screen ] <> Saved_Screen THEN
Save_Screen( Saved_Screen )
END
ELSE
Save_Screen( Saved_Screen );
(* Draw the menu frame *)
Draw_Menu_Frame( XL, YL, XR, YR, Menu.Menu_FColor, Menu.Menu_TColor,
Menu.Menu_Title );
(* Display Menu Entries *)
FOR I := 1 TO Menu.Menu_Size DO
WITH Menu.Menu_Entries[I] DO
BEGIN
GoToXY( Menu_Item_Column , Menu_Item_Row );
WRITE( Menu_Item_Text );
END;
(* Highlight Default Choice *)
Menu_Turn_On( Menu, Menu.Menu_Default );
END (* Menu_Display_Choices *);
(*----------------------------------------------------------------------*)
(* Menu_Get_Choice --- Get Menu Choice *)
(*----------------------------------------------------------------------*)
FUNCTION Menu_Get_Choice( Menu: Menu_Type; Erase_After: BOOLEAN ) : INTEGER;
(*----------------------------------------------------------------------*)
(* *)
(* Function: Menu_Get_Choice *)
(* *)
(* Purpose: Retrieves Menu Choice from current menu *)
(* *)
(* Calling Sequence: *)
(* *)
(* Ichoice := Menu_Get_Choice( Menu : Menu_Type; *)
(* Erase_After: BOOLEAN ) : INTEGER; *)
(* *)
(* Menu --- Currently displayed menu *)
(* Erase_After --- TRUE to erase menu after choice found *)
(* Ichoice --- Returned menu item chosen *)
(* *)
(* Calls: Menu_Click *)
(* Menu_IBMCh *)
(* Menu_Turn_Off *)
(* Menu_Turn_On *)
(* *)
(* Remarks: *)
(* *)
(* The current menu item is highlighted in reverse video. *)
(* It may be chosen by hitting the return key. Movement *)
(* to other menu items is done using the up-arrow and *)
(* down-arrow. *)
(* *)
(* An item may also be chosen by hitting the first character *)
(* of that item. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
C : CHAR;
Current : INTEGER;
Last : INTEGER;
I : INTEGER;
Found : BOOLEAN;
BEGIN (* Menu_Get_Choice *)
Current := Menu.Menu_Default;
Last := Current - 1;
IF Last < 1 THEN Last := Menu.Menu_Size;
REPEAT (* Loop until return key hit *)
(* Read a character *)
READ( Kbd , C );
Menu_Click;
C := UpCase( C );
(* Convert character to menu code *)
IF C = Ch_Esc THEN Menu_IBMCh( C );
(* Process character *)
CASE C OF
Down_arrow,
Space_bar : BEGIN (* Move down menu *)
Last := Current;
Current := Current + 1;
IF Current > Menu.Menu_Size THEN
Current := 1;
END;
Up_arrow : BEGIN (* Move up menu *)
Last := Current;
Current := Current - 1;
IF Current < 1 THEN
Current := Menu.Menu_Size;
END (* Move up menu *);
Ch_Cr : ;
ELSE
Found := FALSE;
FOR I := 1 TO Menu.Menu_Size DO
IF C = UpCase( Menu.Menu_Entries[I].Menu_Item_Text[1] ) THEN
BEGIN
Found := TRUE;
C := Ch_Cr;
Last := Current;
Current := I;
END;
IF ( NOT Found ) THEN Menu_Beep;
END (* Case of C *);
(* Highlight new menu choice *)
IF C IN [ Up_arrow, Down_arrow, Space_bar, Ch_Cr ] THEN
BEGIN
Menu_Turn_Off( Menu, Last );
Menu_Turn_On ( Menu, Current );
END;
UNTIL C = Ch_CR;
(* Return index of chosen value *)
Menu_Get_Choice := Current;
(* Erase menu from display *)
IF Erase_After THEN
BEGIN (* Restore previous screen *)
Restore_Screen( Saved_Screen );
(* Restore global colors *)
Reset_Global_Colors;
END;
END (* Menu_Get_Choice *);
ə