Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB16.ZIP/PIBMENUS.PAS

Pascal/Delphi Source File | 1986-02-15 | 52.6 KB | 1,115 lines

(*----------------------------------------------------------------------*)
(*           PIBMENUS.PAS   --- Menu Routines for Turbo Pascal          *)
(*----------------------------------------------------------------------*)
(*                                                                      *)
(*  Author:  Philip R. Burns                                            *)
(*  Date:    January, 1985                                              *)
(*  Version: 1.0                                                        *)
(*  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.                   *)
(*                                                                      *)
(*           Suggestions for improvements or corrections are welcome.   *)
(*           Please leave messages on Gene Plantz's BBS [phone]  *)
(*           or Ron Fox's BBS [phone].                           *)
(*                                                                      *)
(*           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, and ASCII.PAS.  These files are not           *)
(*          included here, since Turbo 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.  *)
(*                                                                      *)
(*    Note that code for stacked windows is available here.  You may    *)
(*    want to modify this to use compile-time window spaces, or remove  *)
(*    the current push-down stack structure.                            *)
(*                                                                      *)
(*----------------------------------------------------------------------*)
(*                                                                      *)
(*  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)  Call  Menu_Display_Choices  to display menu.  The default   *)
(*          menu choice will be highlighted.                            *)
(*                                                                      *)
(*     (5)  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.                     *)
(*                                                                      *)
(*----------------------------------------------------------------------*)
(*      Updated April 1, 1985.  PibMenus.Fix merged into this file to   *)
(*      allow for differences in Turbo versions 2 and 3.  -CAR-         *)
(*----------------------------------------------------------------------*)



                   (* Character Constants *)

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 *)
   Bell             = #07;   (* Bell *)

   Max_Menu_Items   =  10;   (* Maximum number of menu choices *)

   Dont_Erase_Menu  = FALSE;
   Erase_Menu       = TRUE;


                   (* Menu Types *)
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    : Integer;  (* Row position of menu item            *)
      Menu_Item_Column : Integer;  (* 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      : Integer;                (* Row position of menu      *)
      Menu_Column   : Integer;                (* Column position of menu   *)
      Menu_Width    : Integer;                (* Width of menu             *)
      Menu_Height   : Integer;                (* Height of menu            *)
      Menu_Default  : 1 .. Max_Menu_Items;    (* Default value position    *)
      Menu_TColor   : Integer;                (* Foreground text color     *)
      Menu_BColor   : Integer;                (* BackGround color          *)
      Menu_FColor   : Integer;                (* Frame color               *)

                                              (* Menu items themselves     *)
      Menu_Entries  : Array[ 1 .. Max_Menu_Items ] Of Menu_Entry;
   End;

                   (* Screen Types *)

Const
     Color_Screen_Address   = $B800;   (* Address of color screen          *)
     Mono_Screen_Address    = $B000;   (* Address of mono screen           *)
     Screen_Length          = 4000;    (* 80 x 25 x 2 = screen area length *)
     Max_Saved_Screen       = 5;       (* Maximum no. of saved screens     *)

Type
                                              (* A screen image            *)
   Screen_Type       = Array[ 1 .. Screen_Length ] Of Byte;

   Screen_Ptr        = ^Screen_Image_Type;
   Screen_Image_Type = Record
                          Screen_Image: Screen_Type;
                       End;

                                              (* Screen stack entries      *)
   Saved_Screen_Ptr  = ^Saved_Screen_Type;
   Saved_Screen_Type = Record
                          Screen_Image  : Screen_Type;
                          Screen_Row    : Integer;
                          Screen_Column : Integer;
                          Screen_X1     : Integer;
                          Screen_Y1     : Integer;
                          Screen_X2     : Integer;
                          Screen_Y2     : Integer;
                       End;


                   (* Screen Variables *)

Var
                                              (* Memory-mapped screen area *)
   Actual_Screen        : Screen_Ptr;

                                              (* Saves screen behind menus *)
   Saved_Screen         : Saved_Screen_Ptr;

                                              (* Stack of saved screens    *)
   Saved_Screen_List    : Array[ 1 .. Max_Saved_Screen ] Of Saved_Screen_Ptr;

                                              (* Depth of saved screen stack *)
   Current_Saved_Screen : 0 .. Max_Saved_Screen;

   Menu_Turbo_Version   : Integer             (* Version of Turbo Pascal *);

(*----------------------------------------------------------------------*)
(*          Set_Turbo_Version --- Set version of Turbo Pascal           *)
(*----------------------------------------------------------------------*)

Procedure Set_Turbo_Version;

(*----------------------------------------------------------------------*)
(*                                                                      *)
(*     Procedure:  Set_Turbo_Version                                    *)
(*                                                                      *)
(*     Purpose:   Set version of Turbo Pascal                           *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Set_Turbo_Version;                                            *)
(*                                                                      *)
(*      Calls:   Window                                                 *)
(*                                                                      *)
(*      Remarks:                                                        *)
(*                                                                      *)
(*         This routine heuristically determines which version (2 or 3) *)
(*         of Turbo Pascal it has been compiled with.  This information *)
(*         is needed to save the coordinates of the current window when *)
(*         performing a screen save.                                    *)
(*                                                                      *)
(*----------------------------------------------------------------------*)

BEGIN (* Set_Turbo_Version *)

                                   (* Set an unusual window *)
   Window( 53, 23, 78, 25 );

   IF ( MEM[ Dseg : 4 ] = 52 ) AND
      ( MEM[ Dseg : 5 ] = 22 ) THEN
      Menu_Turbo_Version := 3
   ELSE
      Menu_Turbo_Version := 2;

   Window( 1, 1, 80, 25 );

END   (* Set_Turbo_Version *);

(*----------------------------------------------------------------------*)
(*    Color_Screen_Active --- Determine if color or mono screen         *)
(*----------------------------------------------------------------------*)

Function Color_Screen_Active : Boolean;

(*                                                                      *)
(*     Function:   Color_Screen_Active                                  *)
(*                                                                      *)
(*     Purpose:    Determines if color or mono screen active            *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Color_Active := Color_Screen_Active : Boolean;                *)
(*                                                                      *)
(*           Color_Active --- set to TRUE if the color screen is        *)
(*                            active, FALSE if the mono screen is       *)
(*                            active.                                   *)
(*                                                                      *)
(*     Calls:   INTR                                                    *)
(*                                                                      *)

Var
   Regs : Record       (* 8088 registers *)
             Ax, Bx, Cx, Dx, Bp, Si, Di, Ds, Es, Flags : Integer
          End;

Begin  (* Color_Screen_Active *)

   Regs.Ax := 15 SHL 8;

   INTR( $10 , Regs );

   Color_Screen_Active := ( Regs.Ax AND $FF ) <> 7;

End    (* Color_Screen_Active *);

(*----------------------------------------------------------------------*)
(*        Get_Screen_Address --- Get address of current screen          *)
(*----------------------------------------------------------------------*)

Procedure Get_Screen_Address( Var Actual_Screen : Screen_Ptr );

(*                                                                      *)
(*     Procedure:  Get_Screen_Address                                   *)
(*                                                                      *)
(*     Purpose:    Gets screen address for current type of display      *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Get_Screen_Address( Var Actual_Screen : Screen_Ptr );         *)
(*                                                                      *)
(*           Actual_Screen --- pointer whose value receives the         *)
(*                             current screen address.                  *)
(*                                                                      *)
(*     Calls:   Color_Screen_Active                                     *)
(*              PTR                                                     *)
(*                                                                      *)

Begin  (* Get_Screen_Address *)

   If Color_Screen_Active Then
      Actual_Screen := PTR( Color_Screen_Address , 0 )
   Else
      Actual_Screen := PTR( Mono_Screen_Address , 0 );

End    (* Get_Screen_Address *);

(*----------------------------------------------------------------------*)
(*                Video Display Control Routines                        *)
(*----------------------------------------------------------------------*)
(*                                                                      *)
(*       RvsVideoOn  --- Turn On Reverse Video                          *)
(*       RvsVideoOff --- Turn Off Reverse Video                         *)
(*                                                                      *)
(*----------------------------------------------------------------------*)

Procedure RvsVideoOn( Foreground_Color, Background_Color : Integer );

Begin (* RvsVideoOn *)

   TextColor     ( Background_color );
   TextBackGround( Foreground_color );

End   (* RvsVideoOn *);

(*----------------------------------------------------------------------*)

Procedure RvsVideoOff( Foreground_Color, Background_Color : Integer );

Begin (* RvsVideoOff *)

   TextColor     ( Foreground_color );
   TextBackGround( Background_color );

End   (* RvsVideoOff *);


(*----------------------------------------------------------------------*)
(*                TURBO Pascal Window Location Routines                 *)
(*----------------------------------------------------------------------*)
(*                                                                      *)
(*  These routines and constants give the four corners of the current   *)
(*  Turbo window:                                                       *)
(*                                                                      *)
(*    Lower right-hand corner: (Lower_Right_Column, Lower_Right_Row)    *)
(*    Upper left_hand corner:  (Upper_Left_Column, Upper_Right_Column)  *)
(*                                                                      *)
(*----------------------------------------------------------------------*)

                                   (* Lower right corner of     *)
                                   (* current TURBO window      *)
Var
   Lower_Right_Column  : Byte ABSOLUTE Cseg:$016A;
   Lower_Right_Row     : Byte ABSOLUTE Cseg:$016B;

(*----------------------------------------------------------------------*)
(*    Upper_Left_Column ---  Upper Left Col. Position of current window *)
(*----------------------------------------------------------------------*)

Function Upper_Left_Column : Integer;

(*                                                                      *)
(*     Function:   Upper_Left_Column                                    *)
(*                                                                      *)
(*     Purpose:    Returns upper left col. pos. of current TURBO window *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Pos := Upper_Left_Column : Integer;                           *)
(*                                                                      *)
(*     Calls:   Mem                                                     *)
(*                                                                      *)

Begin  (* Upper_Left_Column *)

   IF Menu_Turbo_Version = 2 THEN
      Upper_Left_Column := MEM[ Dseg:$0156 ] + 1
   ELSE
      Upper_Left_Column := MEM[ Dseg:$0004 ] + 1;

End    (* Upper_Left_Column *);

(*----------------------------------------------------------------------*)
(*    Upper_Left_Row ---  Upper Left Row Position of current window     *)
(*----------------------------------------------------------------------*)

Function Upper_Left_Row : Integer;

(*                                                                      *)
(*     Function:   Upper_Left_Row                                       *)
(*                                                                      *)
(*     Purpose:    Returns upper left row pos. of current TURBO window  *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Pos := Upper_Left_Row : Integer;                              *)
(*                                                                      *)
(*     Calls:   Mem                                                     *)
(*                                                                      *)

Begin  (* Upper_Left_Row *)

   IF Menu_Turbo_Version = 2 THEN
      Upper_Left_Row := Mem[ Dseg:$0157 ] + 1
   ELSE
      Upper_Left_Row := Mem[ Dseg:$0005 ] + 1;

End    (* Upper_Left_Row *);


(*----------------------------------------------------------------------*)
(*                Set/Reset Text Color Routines                         *)
(*----------------------------------------------------------------------*)
(*                                                                      *)
(*   These routines set and reset the global text foreground and        *)
(*   background colors.                                                 *)
(*                                                                      *)
(*----------------------------------------------------------------------*)

                   (* Global Text Color Variables *)

Var
   Global_ForeGround_Color : Integer;
   Global_BackGround_Color : Integer;

(*----------------------------------------------------------------------*)
(*    Set_Global_Colors --- Reset global foreground, background cols.   *)
(*----------------------------------------------------------------------*)

Procedure Set_Global_Colors( ForeGround, BackGround : Integer );

(*                                                                      *)
(*     Procedure:  Set_Global_Colors                                    *)
(*                                                                      *)
(*     Purpose:    Sets global text foreground, background colors.      *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Set_Global_Colors( ForeGround, BackGround : Integer );        *)
(*                                                                      *)
(*           ForeGround --- Default foreground color                    *)
(*           BackGround --- Default background color                    *)
(*                                                                      *)
(*     Calls:   TextColor                                               *)
(*              TextBackGround                                          *)
(*                                                                      *)

Begin  (* Set_Global_Colors *)

   Global_ForeGround_Color := ForeGround;
   GLobal_BackGround_Color := BackGround;

   TextColor     ( Global_ForeGround_Color );
   TextBackground( Global_BackGround_Color );

End    (* Set_Global_Colors *);

(*----------------------------------------------------------------------*)
(*  Reset_Global_Colors --- Reset global foreground, background cols.   *)
(*----------------------------------------------------------------------*)

Procedure Reset_Global_Colors;

(*                                                                      *)
(*     Procedure:  Reset_Global_Colors                                  *)
(*                                                                      *)
(*     Purpose:    Resets text foreground, background colors to global  *)
(*                 defaults.                                            *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Reset_Global_Colors;                                          *)
(*                                                                      *)
(*     Calls:   TextColor                                               *)
(*              TextBackGround                                          *)
(*                                                                      *)

Begin  (* Reset_Global_Colors *)

   TextColor     ( Global_ForeGround_Color );
   TextBackground( Global_BackGround_Color );

End    (* Reset_Global_Colors *);

(*----------------------------------------------------------------------*)
(*                 Screen Manipulation Routines                         *)
(*----------------------------------------------------------------------*)
(*                                                                      *)
(*   These routines save and restore screen images in support of the    *)
(*   windowing facility.  Also, the current screen image can be printed *)
(*   and text extracted from the screen memory.                         *)
(*                                                                      *)
(*----------------------------------------------------------------------*)

(*----------------------------------------------------------------------*)
(*       Get_Screen_Text_Line --- Extract text from screen image        *)
(*----------------------------------------------------------------------*)

Procedure Get_Screen_Text_Line( Var Text_Line     : AnyStr;
                                    Screen_Line   : Integer;
                                    Screen_Column : Integer );

(*                                                                      *)
(*     Procedure:  Get_Screen_Text_Line                                 *)
(*                                                                      *)
(*     Purpose:    Extracts text from current screen image              *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Get_Screen_Text_Line( Var Text_Line     : AnyStr;             *)
(*                                  Screen_Line   : Integer;            *)
(*                                  Screen_Column : Integer );          *)
(*                                                                      *)
(*           Text_Line        --- receives text extracted from screen   *)
(*           Screen_Line      --- line on screen to extract             *)
(*           Screen_Column    --- starting column to extract            *)
(*                                                                      *)
(*     Calls:   None                                                    *)
(*                                                                      *)
(*     Remarks:                                                         *)
(*                                                                      *)
(*        Only the text -- not attributes -- from the screen is         *)
(*        returned.                                                     *)
(*                                                                      *)

Var
   First_Pos  : Integer;
   Last_Pos   : Integer;
   I          : Integer;

Begin  (* Print_Screen *)

   Screen_Line   := Max( Min( Screen_Line   , 25 ) , 1 );
   Screen_Column := Max( Min( Screen_Column , 80 ) , 1 );

   Text_Line     := '';
   First_Pos     := ( ( Screen_Line - 1 ) * 80 + Screen_Column ) * 2;
   Last_Pos      := Screen_Line * 160;

   Repeat
      Text_Line := Text_Line + CHR( Actual_Screen^.Screen_Image[ First_Pos ] );
      First_Pos := First_Pos + 2;
   Until ( First_Pos > Last_Pos );

End    (* Print_Screen *);

(*----------------------------------------------------------------------*)
(*                Print_Screen --- Print current screen image           *)
(*----------------------------------------------------------------------*)

Procedure Print_Screen;

(*                                                                      *)
(*     Procedure:  Print_Screen                                         *)
(*                                                                      *)
(*     Purpose:    Prints current screen image (memory mapped area)     *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Print_Screen;                                                 *)
(*                                                                      *)
(*     Calls:   None                                                    *)
(*                                                                      *)
(*     Remarks:                                                         *)
(*                                                                      *)
(*        Only the text from the screen is printed.                     *)
(*                                                                      *)

Var
   I         : Integer;
   Text_Line : String[80];

Begin  (* Print_Screen *)

   For I := 1 To 25 Do
      Begin
         Get_Screen_Text_Line( Text_Line, I, 1 );
         Writeln( Lst , Text_Line );
      End;

End    (* Print_Screen *);

(*----------------------------------------------------------------------*)
(*                Save_Screen --- Save current screen image             *)
(*----------------------------------------------------------------------*)

Procedure Save_Screen( Var Saved_Screen_Pointer : Saved_Screen_Ptr );

(*                                                                      *)
(*     Procedure:  Save_Screen                                          *)
(*                                                                      *)
(*     Purpose:    Saves current screen image (memory mapped area)      *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Save_Screen( Var Saved_Screen_Pointer : Saved_Screen_Ptr );   *)
(*                                                                      *)
(*           Saved_Screen_Pointer  --- pointer to record receiving      *)
(*                                     screen image, window location,   *)
(*                                     and current cursor location.     *)
(*                                                                      *)
(*     Calls:   Move                                                    *)
(*              Upper_Left_Column                                       *)
(*              Upper_Left_Row                                          *)
(*                                                                      *)
(*     Remarks:                                                         *)
(*                                                                      *)
(*        This version doesn't check for stack overflow.                *)
(*        Caveat Programmer.                                            *)
(*                                                                      *)

Begin  (* Save_Screen *)

   Current_Saved_Screen := Current_Saved_Screen + 1;
   New( Saved_Screen_Pointer );
   Saved_Screen_List[ Current_Saved_Screen ] := Saved_Screen_Pointer;

   With Saved_Screen_Pointer^ Do
      Begin

         Screen_X1     := Upper_Left_Column;
         Screen_Y1     := Upper_Left_Row;
         Screen_X2     := Lower_Right_Column;
         Screen_Y2     := Lower_Right_Row;

         Screen_Row    := WhereY;
         Screen_Column := WhereX;

         Move( Actual_Screen^.Screen_Image, Screen_Image, Screen_Length );

      End;

End   (* Save_Screen *);

(*----------------------------------------------------------------------*)
(*              Restore_Screen --- Restore saved screen image           *)
(*----------------------------------------------------------------------*)

Procedure Restore_Screen( Var Saved_Screen_Pointer : Saved_Screen_Ptr );

(*                                                                      *)
(*     Procedure:  Restore_Screen                                       *)
(*                                                                      *)
(*     Purpose:    Restores previously saved screen image.              *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Restore_Screen( Var Saved_Screen_Pointer: Saved_Screen_Ptr ); *)
(*                                                                      *)
(*           Saved_Screen_Pointer  --- pointer to record with saved     *)
(*                                     screen image, window location,   *)
(*                                     and cursor location.             *)
(*                                                                      *)
(*     Calls:   Window                                                  *)
(*              Move                                                    *)
(*              GoToXY                                                  *)
(*                                                                      *)
(*     Remarks:                                                         *)
(*                                                                      *)
(*        All saved screen pointers from the last saved down to the     *)
(*        argument pointer are popped from the saved screen list.       *)
(*                                                                      *)

Begin  (* Restore_Screen *)

   With Saved_Screen_Pointer^ Do
      Begin

         Window( Screen_X1, Screen_Y1, Screen_X2, Screen_Y2 );

         Move( Screen_Image, Actual_Screen^.Screen_Image, Screen_Length );

         GoToXY( Screen_Column, Screen_Row );

      End;

   While( Saved_Screen_List[ Current_Saved_Screen ] <> Saved_Screen_Pointer ) Do
      Current_Saved_Screen := Current_Saved_Screen - 1;

   If Current_Saved_Screen > 0 Then
      Current_Saved_Screen := Current_Saved_Screen - 1;

   Dispose( Saved_Screen_Pointer );

End    (* Restore_Screen *);

(*----------------------------------------------------------------------*)
(*                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                                                  *)
(*                                                                      *)
(*     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;

Begin (* Draw_Menu_Frame *)

                                   (* Move to top left-hand corner of menu *)
   GoToXY( UpperLeftX, UpperLeftY );

   L  := LowerRightX - UpperLeftX;
   LT := LENGTH( Menu_Title );
                                   (* Adjust title length if necessary *)
   If LT > ( L - 5 ) Then Menu_Title[0] := CHR( L - 5 );

                                   (* Color for frame                  *)
   TextColor( Frame_Color );
                                   (* Write upper left hand corner and title *)
   If LT > 0 Then
      Begin
         Write('╒[ ');
         TextColor( Title_Color );
         Write( Menu_Title );
         TextColor( Frame_Color );
         Write(' ]');
      End
   Else
      Write('╒════');
                                   (* Draw remainder of top of frame *)

   For I := ( UpperLeftX + LT + 5 ) To ( LowerRightX - 1 ) Do Write('═');

   Write('╕');
                                  (* Draw sides of frame *)

   For I := UpperLeftY+1 To LowerRightY-1 Do
      Begin
         GoToXY( UpperLeftX  , I );  Write( '│' );
         GoToXY( LowerRightX , I );  Write( '│' );
      End;

                                  (* Draw bottom of frame     *)

   GoToXY( UpperLeftX, LowerRightY );
   Write( '╘' );

   For I := UpperLeftX+1 To LowerRightX-1 Do Write( '═' );
   Write( '╛' );

                                   (* Establish scrolling window area *)

   Window( UpperLeftX+1, UpperLeftY+1, LowerRightX-2, LowerRightY-1 );

                                   (* Clear out the window area       *)
   ClrScr;
                                   (* 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 *)

  Sound( 2000 );
  Delay( 10 );
  NoSound;

End   (* Menu_Click *);

(*----------------------------------------------------------------------*)
(*                Menu_Beep --- Ring Terminal Bell                      *)
(*----------------------------------------------------------------------*)

Procedure Menu_Beep;

(*                                                                      *)
(*     Procedure:  Menu_Beep                                            *)
(*                                                                      *)
(*     Purpose:    Rings Terminal Bell                                  *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Menu_Beep;                                                    *)
(*                                                                      *)
(*     Calls:    None                                                   *)
(*                                                                      *)

Begin (* Menu_Beep *)

   Write( Bell );

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                                                 *)
(*               NormVideo                                              *)
(*                                                                      *)

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;

   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 *)
   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.                                                  *)
(*                                                                      *)

Var
   C       : Char;
   Current : Integer;
   Last    : Integer;

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;
                                   (* 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 *);

         Else
            If C <> ch_cr Then Menu_Beep;

      End (* Case of C *);
                                   (* Highlight new menu choice *)

      If C In [ Up_arrow, Down_arrow, Space_bar ] 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 *);