Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MENUDOW.ZIP/MENDOWS.INC

Text File | 1986-09-30 | 18.7 KB | 681 lines

CONST
   Top_Left_Char     = #201;
   Top_Right_Char    = #187;
   Bottom_Left_Char  = #200;
   Bottom_Right_Char = #188;
   Vertical_Char     = #186;
   Horizontal_Char   = #205;
   Left_Title_Char   = #91;
   Right_Title_Char  = #93;
   Pg_Up             = ^W;
   Pg_Down           = ^Z;
   Up_Arrow          = ^E;
   Down_Arrow        = ^X;
   Left_Arrow        = ^S;
   Right_Arrow       = ^D;
   INSERT            = ^U;
   CR                = #13;
   ESC               = #27;
   Bell              = #7;



   TitleLen          = 74;
   _PromptLen        = 76;
   DrawStrLen        = 50;

   MaxDrawItems   = 50;
   BaseMenuMove = 1;

Type
  XTCoord=1..80;
  YTCoord=1..25;
  XTCoord0=0..80;
  YTCoord0=0..25;

  TitleStr         = STRING[TitleLen];
  _PromptStr        = STRING[_PromptLen];

  WindowRec=Record
              XSize: XTCoord;
              YSize: YTCoord;
              XPosn: XTCoord;
              YPosn: YTCoord;
              Contents: Array [0..1999] Of Integer;
            End;

  WindowPtr=^WindowRec;

  _PromptRec = RECORD
                 _Prompt_Row : XTCoord;
                 _Prompt_Col : YTCoord;
                 _Prompt     : _PromptStr;
               END;

  _PromptPtr = ^_PromptRec;

  _Title_Opt_Set = SET OF (Header,Footer);
  CharSet = SET OF CHAR;

  TitleOptRange = Header..Footer;
  DrawItemRange = 1..MaxDrawItems;

  DrawStr       = STRING[DrawStrLen];


  RawDrawRec = RECORD
                  Row      : 2..24;
                  Col      : 2..79;
                  DrawDat  : DrawStr;
               END;

  DrawAr     = ARRAY[DrawItemRange] OF RawDrawRec;

  DrawRec    = RECORD
                   Count       : DrawItemRange;
                   Default     : DrawItemRange;
                   Title       : TitleStr;
                   DrawRecAr   : DrawAr;
                END;

Var
  ScreenBase: Integer;

  WindowXLo: XTCoord;
  WindowYLo: YTCoord;
  WindowXHi: XTCoord;
  WindowYHi: YTCoord;

  WinData  : WindowPtr;
  MenuMoveFactor : INTEGER;

PROCEDURE Rvs_Video;
BEGIN
   TEXTCOLOR(BLACK);
   TEXTBACKGROUND(WHITE);
END;

PROCEDURE Reg_Video;
BEGIN
   TEXTCOLOR(WHITE);
   TEXTBACKGROUND(BLACK);
END;

procedure ReadIBMch(var ch: char);
var   ech: char;
begin  {  ReadIBMch  }
{$U-}
  ch := #00;
  Read(kbd,ch);
  if (ch = ^[) and KeyPressed  then
    begin
      Read(kbd,ech);   ch := #00;
      case Ord(ech)  of
        15 : ch := ^O;  { BACK TAB }

        59 : ch := #131;{ PF 1 (HELP) KEY }
        60 : ch := #132;{ PF 2 }
        61 : ch := #133;{ PF 3 }
        62 : ch := #134;{ PF 4 }
        63 : ch := #135;{ PF 5 }
        64 : ch := #136;{ PF 6 }
        65 : ch := #137;{ PF 7 }
        66 : ch := #138;{ PF 8 }
        67 : ch := #139;{ PF 9 }
        68 : ch := #140;{ PF 10 }

        72 : ch := ^E;  { CURSOR UP }
        73 : ch := ^W;  { PAGE UP }
        75 : ch := ^S;  { CURSOR LEFT }
        77 : ch := ^D;  { CURSOR RIGHT }
        79 : ch := ^F;  { END }
        80 : ch := ^X;  { CURSOR DOWN }
        81 : ch := ^Z;  { PAGE DOWN }
        82 : ch := ^U;  { INSERT }
        83 : ch := ^G;  { DELETE }
      else Write(^G);  (* Sound Speaker *)
      end;  {case }
    end;
{$U+}
end;   {  ReadIBMch  }

PROCEDURE Read_Cursor_Pad(    Valid_Set     : CharSet;
                          VAR Cursor_Choice : CHAR);

VAR
   TCh            : CHAR;
   Cursor_Pressed : BOOLEAN;
   Two_Char_Input : BOOLEAN;

BEGIN
   Cursor_Pressed := FALSE;
   REPEAT
      ReadIBMCh(TCh);

      CASE TCh OF
         Up_Arrow,
         Down_Arrow,
         CR,
         ESC,
         Insert : Cursor_Pressed := TRUE;
         ELSE
         BEGIN
            TCh := UPCASE(TCh);
            IF (TCh IN Valid_Set) THEN
               Cursor_Pressed := TRUE
            ELSE
            BEGIN
               WRITE(Bell);
               Cursor_Pressed := FALSE;
            END; { IF (TCh : ELSE }
         END; { CASE TCh : ELSE }
      END; { CASE TCh }

   UNTIL Cursor_Pressed;
   Cursor_Choice := TCh;
END; { Read_Cursor_Pad }

PROCEDURE Click;
BEGIN
   SOUND(2000);
   DELAY(10);
   NOSOUND;
END;

Procedure TurboWindow(XL: XTCoord; YL: YTCoord; XH: XTCoord; YH: YTCoord);
  Begin
    Window(XL,YL,XH,YH);
  End;


Procedure Window(XL: XTCoord; YL: YTCoord; XH: XTCoord; YH: YTCoord);

  Begin
    TurboWindow(XL,YL,XH,YH);
    WindowXLo:=XL;
    WindowYLo:=YL;
    WindowXHi:=XH;
    WindowYHi:=YH;
  End;

Function SaveWindow(XLow: XTCoord; YLow: YTCoord;
                    XHigh: XTCoord; YHigh:YTCoord): WindowPtr;

  Var
    SW: WindowPtr;
    I: Integer;
    XS: XTCoord;
    YS: YTCoord;

  Begin
    XS:=XHigh-XLow+1;
    YS:=YHigh-YLow+1;
    GetMem(SW,2*XS*YS + 4);
    With SW^ Do
     Begin
      XSize:=XS;
      YSize:=YS;
      XPosn:=XLow;
      YPosn:=YLow;
      For I:=0 To YSize-1 Do
        Move(Mem[ScreenBase:((YPosn+I-1)*80+XPosn-1) Shl 1],
             Contents[I*XSize],XSize Shl 1);
     End;
    SaveWindow:=SW;
  End;

Function SaveCurrentWindow: WindowPtr;
  Begin
    SaveCurrentWindow:=SaveWindow(WindowXLo,WindowYLo,WindowXHi,WindowYHi);
  End;

Procedure RestoreWindow(WP: WindowPtr; XPos: XTCoord0; YPos: YTCoord0);

  Var
    I: Integer;

  Begin
    With WP^ Do
     Begin
      If XPos=0 Then XPos:=XPosn;
      If YPos=0 Then YPos:=YPosn;
      For I:=0 To YSize-1 Do
        Move(Contents[I*XSize],
             Mem[ScreenBase:2*((YPos+I-1)*80+XPos-1)],XSize*2);
     End;
  End;

Procedure DisposeWindow(Var WP: WindowPtr);

  Begin
    With WP^ Do FreeMem(WP,2*XSize*YSize+4);
    WP:=Nil;
  End;

Procedure DRestoreWindow(Var WP: WindowPtr; XPos: XTCoord0; YPos: YTCoord0);

  Begin
    RestoreWindow(WP, XPos, YPos);
    DisposeWindow(WP);
  End;

Procedure DRestoreCurrentWindow(Var WP: WindowPtr;
                                XPos: XTCoord0; YPos: YTCoord0);

  Begin
    With WP^ Do
     Begin
      If XPos=0 Then XPos:=XPosn;
      If YPos=0 Then YPos:=YPosn;
      Window(XPos,YPos,XPos+XSize-1,YPos+YSize-1);
     End;
    DRestoreWindow(WP, XPos, YPos);
  End;

Procedure DetermineDisplay;

  Var
    M,C: Integer;
    T: Byte;

  Begin
    M:=MemW[$B000:0];
    C:=MemW[$B800:0];
    T:=64;
    If (Hi(M)=T) Or (Hi(C)=T) Then T:=65;
    If (Hi(M)=T) Or (Hi(C)=T) Then T:=66;
    GotoXY(1,1);
    Write(Chr(T));
    GotoXY(1,1);
    If Mem[$B000:0]=T Then ScreenBase:=$B000
    Else ScreenBase:=$B800;
    MemW[$B000:0]:=M;
    MemW[$B800:0]:=C;
  End;



PROCEDURE Make_Window_Border(BorderXL : XTCoord;BorderYL : YTCoord;
                           BorderXH : XTCoord;BorderYH : YTCoord);
VAR
   I : INTEGER;

BEGIN
   GOTOXY(1,BorderYH-BorderYL);
   WRITE(Bottom_Left_Char);
   FOR I := 2 TO BorderXH - BorderXL DO
      WRITE(Horizontal_Char);
   WRITE(Bottom_Right_Char);
   GOTOXY(1,BorderYH-BorderYL);
   INSLINE;
   GOTOXY(1,1);
   WRITE(Top_Left_Char);
   FOR I := 2 TO (BorderXH - BorderXL) DO
      WRITE(Horizontal_Char);
   WRITE(Top_Right_Char);
   FOR I := 2 TO BorderYH - BorderYL DO
   BEGIN
      GOTOXY(1,I);
      WRITE(Vertical_Char);
      GOTOXY(BorderXH-BorderXL + 1,I);
      WRITE(Vertical_Char);
   END;

END;

PROCEDURE Make_Window_Title(Current_Title : TitleStr;
                            Current_XH,
                            Current_XL            : XTCoord;
                            Current_YH            : YTCoord;
                            Current_Title_Opt     : TitleOptRange);

VAR
   XLength,
   Title_XPos     : XTCoord;
   Title_YPos     : YTCoord;

BEGIN
   XLength := Current_XH - Current_XL + 1;
   IF (LENGTH(Current_Title) + 4) > XLength THEN
      Current_Title := COPY(Current_Title,1,XLength);

   IF Current_Title_Opt = Header THEN
      Title_YPos := 1
   ELSE
      Title_YPos := Current_YH;
   Title_XPos := (XLength DIV 2) - ((LENGTH(Current_Title) + 4) DIV 2);
   Current_Title := Left_Title_Char + ' ' + Current_Title + ' ' +
                    Right_Title_Char;

   GOTOXY(Title_Xpos,Title_Ypos);
   TEXTBACKGROUND(WHITE);
   TEXTCOLOR(BLACK);
   WRITE(Current_Title);
   TEXTCOLOR(WHITE);
   TEXTBACKGROUND(BLACK);

END;


FUNCTION Make_Window(MakeXL              : XTCoord;
                     MakeYL              : YTCoord;
                     MakeXH              : XTCoord;
                     MakeYH              : YTCoord;
                     MakeTitle           : TitleStr;
                     VAR Make_Window_Dat : WindowPtr;
                     Make_Clr_Scrn       : BOOLEAN
                    ) : BOOLEAN;

VAR
   Window_Size_Ok : BOOLEAN;
   NewXL,
   NewXH          : XTCoord;
   NewYL,
   NewYH          : YTCoord;

BEGIN
   IF (MakeXH < (MakeXL + 2)) OR (MakeYH < (MakeYL + 2)) THEN
      Window_Size_Ok := FALSE
   ELSE
      BEGIN
         NewXH := MakeXH - 1;
         NewYH := MakeYH - 1;
         NewXL := MakeXL + 1;
         NewYL := MakeYL + 1;
         Window_Size_Ok := TRUE;
         GOTOXY(MakeXH-MakeXL,1);
      END;

   IF Window_Size_Ok THEN
      BEGIN
         Window(MakeXL,MakeYL,MakeXH,MakeYH);
         Make_Window_Dat := SaveWindow(MakeXL,MakeYL,MakeXH,MakeYH);
         IF Make_Clr_Scrn THEN
            CLRSCR;
         Make_Window_Border(MakeXL,MakeYL,MakeXH,MakeYH);
         Make_Window_Title(MakeTitle,MakeXH,MakeXL,MakeYH,Header);
         Window(NewXL,NewYL,NewXH,NewYH);
      END;

   Make_Window := Window_Size_Ok;
END;

PROCEDURE Draw_Window(Draw_Dat : DrawRec);

VAR
   I : DrawItemRange;

BEGIN
   WITH Draw_Dat DO
   BEGIN
      FOR I := 1 TO Count DO
      BEGIN
         WITH DrawRecAr[I] DO
         BEGIN
            GOTOXY(Col,Row);
            WRITE(DrawDat);
         END;
      END;
   END;
END;

PROCEDURE Menu_Items_Display(    In_Menu            : DrawRec;
                             VAR Menu_Valid_Choices : CharSet);

VAR
   I : INTEGER;
   MenuItems_Valid : CharSet;
   InValid         : BOOLEAN;
   Ch              : CHAR;

BEGIN
   MenuItems_Valid := [];
   InValid := FALSE;
   WITH In_Menu DO
      FOR I := 1 TO Count DO
         BEGIN
            GOTOXY(2,I);
            WRITE(DrawRecAr[I].DrawDat);
            Ch := DrawRecAr[I].DrawDat[1];
            IF Ch IN MenuItems_Valid THEN
               InValid := TRUE
            ELSE
               MenuItems_Valid := MenuItems_Valid + [Ch];
         END;
   If InValid THEN
      MenuItems_Valid := [];
   Menu_Valid_Choices := MenuItems_Valid;
END;

PROCEDURE Menu_Display(    Menu_Rec         : DrawRec;
                       VAR Menu_Window_Dat  : WindowPtr;
                       VAR Menu_Valid_Chars : CharSet);

VAR
  Tem : BOOLEAN;
  MenuXL : XTCoord;
  MenuYL : YTCoord;
  MenuXH : XTCoord;
  MenuYH : YTCoord;

BEGIN
   WITH Menu_Rec DO
   BEGIN
      MenuXL := DrawRecAr[1].Col;
      MenuYL := DrawRecAr[1].Row;
      MenuXH := DrawRecAr[2].Col;
      MenuYH := DrawRecAr[2].Row;
   END; { WITH Menu_Rec }

   Tem := Make_Window(MenuXL,MenuYL,MenuXH,MenuYH,
                      Menu_Rec.Title,Menu_Window_Dat,TRUE);
   CLRSCR;
   Menu_Items_Display(Menu_Rec,Menu_Valid_Chars);
END;

FUNCTION Move_Menu(VAR Move_Rec : DrawRec;
                       Move_Window : WindowPtr) : BOOLEAN;

VAR
   Move_Exit : BOOLEAN;
   MCh       : CHAR;
   Old_Col1  : XTCoord;
   Old_Col2  : XTCoord;
   Old_Row1  : YTCoord;
   Old_Row2  : YTCoord;
   Move_More : BOOLEAN;
   Move_Int  : BOOLEAN;

BEGIN
   Move_Exit := FALSE;
   REPEAT
      ReadIBMCh(MCh);
      WITH Move_Rec DO
      BEGIN
         Move_Exit := FALSE;
         Old_Col1 := DrawRecAr[1].Col;
         Old_Col2 := DrawRecAr[2].Col;
         Old_Row1 := DrawRecAr[1].Row;
         Old_Row2 := DrawRecAr[2].Row;
         CASE MCh OF
            Left_Arrow : BEGIN
                            Move_More := TRUE;
                            Move_Exit := TRUE;
                            IF (Old_Col1 > MenuMoveFactor) THEN
                            BEGIN
                               DrawRecAr[1].Col := DrawRecAr[1].Col -
                                                   MenuMoveFactor;
                               DrawRecAr[2].Col := DrawRecAr[2].Col -
                                                   MenuMoveFactor;
                            END; { IF Old_Col1 }
                         END; { CASE MCh : Left_Arrow }
            Right_Arrow : BEGIN
                             Move_More := TRUE;
                             Move_Exit := TRUE;
                             IF (Old_Col2 < (81 - MenuMoveFactor)) THEN
                             BEGIN
                                DrawRecAr[1].Col := DrawRecAr[1].Col +
                                                    MenuMoveFactor;
                                DrawRecAr[2].Col := DrawRecAr[2].Col +
                                                    MenuMoveFactor;
                             END; { IF Old_Col2 }
                          END; { CASE MCh : Right_Arrow }
            Up_Arrow : BEGIN
                          Move_More := TRUE;
                          Move_Exit := TRUE;
                          IF (Old_Row1 > MenuMoveFactor) THEN
                          BEGIN
                             DrawRecAr[1].Row := DrawRecAr[1].Row -
                                                 MenuMoveFactor;
                             DrawRecAr[2].Row := DrawRecAr[2].Row -
                                                 MenuMoveFactor;
                          END; { IF Old_Row1 }
                       END; { CASE MCh : Up_Arrow }
            Down_Arrow : BEGIN
                            Move_More := TRUE;
                            Move_Exit := TRUE;
                            IF (Old_Row2 < (25 - MenuMoveFactor)) THEN
                            BEGIN
                               DrawRecAr[1].Row := DrawRecAr[1].Row +
                                                   MenuMoveFactor;
                               DrawRecAr[2].Row := DrawRecAr[2].Row +
                                                   MenuMoveFactor;
                            END; { IF Old_Row2 }
                         END; { CASE MCh : Down_Arrow }
            Pg_Up : BEGIN
                       Move_More := TRUE;
                       Move_Exit := TRUE;
                       DrawRecAr[1].Row := 1;
                       DrawRecAr[2].Row := Old_Row2 - Old_Row1 + 1;
                    END; { CASE MCh : Pg_Up }
            Pg_Down : BEGIN
                         Move_More := TRUE;
                         Move_Exit := TRUE;
                         DrawRecAr[2].Row := 24;
                         DrawRecAr[1].Row := 24 - (Old_Row2 - Old_Row1);
                      END; { CASE MCh : Pg_Down }
            '1'..'9' : BEGIN
                          Move_More := TRUE;
                          Move_Exit := FALSE;
                          MenuMoveFactor := ORD(MCh) - 48;
                       END; { CASE MCh : '1'..'9' }
            Insert : BEGIN
                        Move_Exit := TRUE;
                        Move_More := FALSE;
                     END; { CASE MCh : Insert }
            ELSE
            BEGIN
               Move_Exit := FALSE;
               WRITE(Bell);
            END;
         END; { CASE MCh }
      END; { WITH Move_Rec }
   UNTIL Move_Exit;

   DRestoreCurrentWindow(Move_Window,0,0);
   Move_Menu := Move_More;
END; { Move_Window }



FUNCTION Menu_Choice(Choice_Rec     : DrawRec;
                     Choice_Valid   : CharSet) : INTEGER;
VAR
   Row              : YTCoord;
   Cursor_Ch        : CHAR;
   Cur_Choice,I     : INTEGER;
   Exit_Menu_Choice : BOOLEAN;

BEGIN
   Exit_Menu_Choice := FALSE;

   WITH Choice_Rec DO
   BEGIN
      Row := Default;
      WHILE NOT Exit_Menu_Choice
      BEGIN
         GOTOXY(2,Row);
         Rvs_Video;
         WRITE(DrawRecAr[Row].DrawDat);
         Reg_Video;

         Read_Cursor_Pad(Choice_Valid,Cursor_Ch);
         GOTOXY(1,Row);
         WRITE(' ',DrawRecAr[Row].DrawDat,' ');

         CASE Cursor_Ch OF
            ESC        : BEGIN
                            Cur_Choice := 0;
                            Exit_Menu_Choice := TRUE;
                         END; { CASE Cursor_Ch : ESC }
            CR         : BEGIN
                            Cur_Choice := Row;
                            Exit_Menu_Choice := TRUE;
                         END; { CASE Cursor_Ch : CR }
            Up_Arrow   : BEGIN
                            Row := PRED(Row);
                            Exit_Menu_Choice := FALSE;
                            IF Row = 0 THEN
                               Row := Count;
                            Click;
                         END; { CASE Cursor_Ch : Up_Arrow }
            Down_Arrow : BEGIN
                            Row := SUCC(Row);
                            Exit_Menu_Choice := FALSE;
                            IF Row > Count THEN
                               Row := 1;
                            Click;
                         END; { CASE Cursor_Ch : Down_Arrow }
            Insert : BEGIN
                        Cur_Choice := -1;
                        Exit_Menu_Choice := TRUE;
                     END; { CASE Cursor_Ch : Insert }
            ELSE         BEGIN
                            Cur_Choice := 0;
                            Exit_Menu_Choice := TRUE;
                            FOR I := 1 TO Count DO
                               IF DrawRecAr[I].DrawDat[1] = Cursor_Ch THEN
                                  Cur_Choice := I;
                         END;
         END { Case Cursor_Ch };
      END { While Not Exit_Menu_Choice };
   END { With Choice_Rec };
   Menu_Choice := Cur_Choice;
END;

FUNCTION Make_Menu(VAR MakeMenu_Rec     : DrawRec;
                   VAR MakeMenu_Window  : WindowPtr;
                       MakeMenu_Erase   : BOOLEAN)  : INTEGER;

VAR
   Menu_Window      : WindowPtr;
   MakeMenu_Choice  : INTEGER;
   MakeMenu_Valid   : CharSet;
   MakeMenu_Exit    : BOOLEAN;
   Make_Move        : BOOLEAN;

BEGIN
   MenuMoveFactor := BaseMenuMove;
   Make_Move := FALSE;
   REPEAT
      MakeMenu_Exit := TRUE;
      Menu_Display(MakeMenu_Rec,Menu_Window,MakeMenu_Valid);
      IF (NOT Make_Move) THEN
         MakeMenu_Choice := Menu_Choice(MakeMenu_Rec,MakeMenu_Valid);
      IF (MakeMenu_Choice = -1) OR (Make_Move) THEN
      BEGIN
         Make_Move := Move_Menu(MakeMenu_Rec,Menu_Window);
         MakeMenu_Exit := FALSE;
      END; { IF (MakeMenu_Choice }
   UNTIL MakeMenu_Exit;

   IF MakeMenu_Erase THEN
   BEGIN
      DRestoreCurrentWindow(Menu_Window,0,0);
      Menu_Window := NIL;
   END;
   MakeMenu_Window := Menu_Window;

   Make_Menu := MakeMenu_Choice;
END; { Make_Menu }