Power-Programmierung/CD1.mdf/pascal/library/dos/box/example2.pas

Pascal/Delphi Source File | 1980-01-01 | 13.4 KB | 436 lines

USES CRT,DOS;

CONST
   MaxPicks   = 9;       {increase for more menu items}

TYPE
   Map     = Record
             ScrCh : Char;
             ScrAt : Byte;
             End;
   Screen  = Array[1..25,1..80] of Map;
   AnyStr  = String[80];
   FileName= String[12];

VAR
    R          : Registers;
    FilevarM   : File;
    CS         : Screen absolute $B800:0000;
    MS         : Screen absolute $B000:0000;
    LoadScr    : Screen;
    Scr        : Array[1..2] of Screen;
    HelpContext: Integer;
    FunctKey   : Boolean;
    Color      : Boolean;
    BigExit    : Boolean;
    Ch         : Char;
    NPicks     : Integer;
    MP         : Integer;
    LastMP     : Integer;
    XBeg       : Array[1..MaxPicks] of Integer;
    YBeg       : Array[1..MaxPicks] of Integer;
    Len        : Array[1..MaxPicks] of Integer;
    Attr       : Array[1..MaxPicks] of Byte;
    CapCh      : Array[1..MaxPicks] of Char;
{=====================================================}
{                                                     }
{  This Procedure produces a sound on the speaker     }
{                                                     }
PROCEDURE Beep(Freq:Integer);
BEGIN
     Sound(Freq);Delay(200);Nosound;
END;

{=====================================================}
{                                                     }
{  This Procedure returns Color = True if the PC      }
{  has a color graphics adapter.                      }
{                                                     }
PROCEDURE CheckColor;
BEGIN
     If (Mem[0000:1040] and 48) <> 48
        then Color := True
        else Color := False;
END;

{=====================================================}
{                                                     }
{  This Procedure hides the cursor by moving it off   }
{  the screen.                                        }
{                                                     }
PROCEDURE HideCursor;
  Begin
    R.AX := $0200;
    R.DX := $1900;
    R.BX := $0000;
    Intr($10,R);
  End;

{=====================================================}
{                                                     }
{  This Procedure Saves the current screen so         }
{  that it can be restored later.                     }
{                                                     }
PROCEDURE SaveScreen(NS:Integer);
BEGIN
 If Color then Move(CS,Scr[NS],4000)
          else Move(MS,Scr[NS],4000);
END;

{=====================================================}
{                                                     }
{  This Procedure restores the screen  saved          }
{  in Procedure SaveScreen.                           }
{                                                     }
PROCEDURE RestoreScreen(NS:Integer);
BEGIN
 If Color then Move(Scr[NS],CS,4000)
          else Move(Scr[NS],MS,4000);
END;

{=====================================================}
PROCEDURE MemoryLoad(MFile : AnyStr);
{                                                     }
{ This procedure displays a memory format screen      }
{ image produced by BOX by reading in the file and    }
{ loading the image directly into the video buffer    }
{                                                     }
BEGIN
      Assign(FilevarM,MFile);
      {$I-} Reset(FilevarM,4000); {$I+}
      If IOresult = 0 then       {found good file name}
        Begin
        BlockRead(FilevarM,LoadScr,1);
          If Color then CS := LoadScr
                   else MS := LoadScr;
          Close(FilevarM);
        End
      Else                         {couldn't find file}
        Begin
          GoToXY(1,24);
          Write('ERROR - Could not find file');
        End;
END; {MemoryLoad}

{=====================================================}
PROCEDURE HelpMsg;
{                                                     }
{  This procedure displays a Help screen depending    }
{  on the value of HelpContext, a variable set by     }
{  programmer to different values in different places }
{  depending on the Help screen needed.  EXHELP       }
{  files are used only for an example.  You need to   }
{  substitute your own help files.                    }
{                                                     }
VAR
   SaveX,SaveY : Integer;
BEGIN
    SaveScreen(2);     {Save the current screen}
    SaveX := WhereX; SaveY := WhereY;
    Case HelpContext of
     1 : MemoryLoad('EXHELP.1');
     2 : MemoryLoad('EXHELP.2');
{    3 : MemoryLoad('EXHELP.3');   add more help      }
{    4 : MemoryLoad('EXHELP.4');   screens here       }
    End; {case}
    GoToXY(1,25);Write('Hit any key to continue');
    Ch := ReadKey;
    RestoreScreen(2);  {Restore the screen as it was}
    GoToXY(SaveX,SaveY);
END;

{=====================================================}
FUNCTION NextKey:Char;
{                                                     }
{  This Function reads in a keystroke.  If the key is }
{  F1 the function flashes a Help screen.  If the key }
{  is any other character the function passes it on.  }
{                                                     }
CONST
    Help = #59;
VAR
    NKey : Char;
LABEL
    Start;
BEGIN
Start:NKey := ReadKey;
      If NKey <> #0 then FunctKey := False else
        Begin
          NKey := ReadKey;
          If(NKey = Help) then
          Begin
           HelpMsg;
           GoTo Start;
          End;
          FunctKey := True;
        End;
      NextKey := NKey;
END;

{=====================================================}
{                                                     }
{   This function finds and returns the first         }
{   Capital letter in a string                        }
{                                                     }
FUNCTION FirstCap(St : AnyStr; Len : Integer): Char;
VAR
   II : Integer;
BEGIN
 FirstCap := '?';
 For II := 1 to Len Do
  Begin
   If St[II] in ['A'..'Z','0'..'9'] then
     Begin
       FirstCap := St[II];
       Exit;
     End;
  End;
END;

{=====================================================}
{                                                     }
{  This Procedure finds the menu picks on LoadScr     }
{                                                     }
PROCEDURE FindPicks;
VAR
      YY,II,XT,LT      : Integer;
      MenuLine         : AnyStr;

BEGIN
     For II := 1 to MaxPicks do begin
       XBeg[II] := 0;
       YBeg[II] := 0;
       Len[II]  := 0;
       CapCh[II] := '?';
     End;
     YY := 1;
     NPicks := 0;
     Repeat
         For II := 1 to 80 do
          MenuLine[II] := LoadScr[YY,II].ScrCh;
         MenuLine[0] := chr(80);
         XT := pos('[',MenuLine);
         If XT > 0 then begin
           If NPicks < MaxPicks
            then NPicks := NPicks + 1;
           XBeg[NPicks] := XT;
           YBeg[NPicks] := YY;
           If Color
             then Attr[NPicks] := LoadScr[YY,XT].ScrAt
             else Attr[NPicks] := 7;

           LT := pos(']',copy(Menuline,XT+1,80-XT));
           If LT > 0 then Len[NPicks] := LT+1
                     else Len[NPicks] := 80-XT+1;
           MenuLine[XT] := ' ';
           MenuLine[XT+LT] := ' ';
           CapCh[NPicks] :=
             FirstCap(Copy(Menuline,XT+1,LT),LT);
           LoadScr[YY,XT].ScrCh := ' ';
           LoadScr[YY,XT+LT].ScrCh := ' ';
         End
        else YY := YY + 1;
     Until YY = 26;
END;

{=====================================================}
{                                                     }
{  This procedure displays the menu.  See file        }
{  EXMENU.MEM to see how this procedure works.        }
{                                                     }
PROCEDURE ShowMenu(MenuFile:FileName);
BEGIN
      CheckColor;
      MP := 1;              {initialize Menu Pick}
      LastMP := 1;          {initialize last Menu Pick}
      Assign(FilevarM,MenuFile);
      {$I-} Reset(FilevarM,4000); {$I+}
      If IOresult = 0 then
       Begin
        BlockRead(FilevarM,LoadScr,1);
        FindPicks;
        If Color then CS := LoadScr
                 else MS := LoadScr;
        Close(FilevarM);
       End

      Else
       Begin
         GoToXY(1,24);
         Write('Could not find file ',MenuFile);
         Ch := ReadKey;
       End;
END; {ShowMenu}

{=====================================================}
{                                                     }
{  Changes the color attribute at X,Y for Length Len  }
{  to attribute Att.  Useful for making a bar cursor  }
{                                                     }
PROCEDURE ColorChange(X,Y,Len:Integer;Att:Byte);
VAR
   II      : Integer;
BEGIN

   For II := 1 to Len do begin
     If color then
      begin
       while ((port[$3DA] and 8) = 8) do;
       {wait for vertical retrace}
       CS[Y,X-1+II].ScrAT := Att;
       {change the color attribute}
      end
     else MS[Y,X-1+II].ScrAT := Att;
   End;
END;

{=====================================================}
{                                                     }
{  Displays menu pick P in reverse video.             }
{                                                     }
PROCEDURE Reverse(P:Integer);
VAR
   RAttr   : Byte;
BEGIN

   {Flip flop the first and last 8 bits of }
   {the color attribute byte to produce    }
   {reverse video of the menu line's original color}

   RAttr := (Attr[P] shr 4) or ((Attr[P] and 7) shl 4);
   ColorChange(XBeg[P],YBeg[P],Len[P],RAttr);
END;

{=====================================================}
{                                                     }
{  Restores menu pick P to original video color.      }
{                                                     }
PROCEDURE Restore(P:Integer);
BEGIN
   ColorChange(XBeg[P],YBeg[P],Len[P],Attr[P]);
END;

{=====================================================}
{                                                     }
{  This function lets the user play with the menu     }
{  and returns a character indicating the menu pick   }
{  he selected.                                       }
{                                                     }
FUNCTION MenuPick:Char;
CONST
   Enter      = #13;
   Escape     = #27;
   DownArrow  = #80;
   UpArrow    = #72;
   RightArrow = #77;
   LeftArrow  = #75;
   Home       = #71;
   EndKey     = #79;
VAR
      ExitMenuPick,NoMatch : Boolean;
      Ytemp                : Integer;
      ErrCode,II           : Integer;
BEGIN;
       ExitMenuPick := False;
  Repeat
       HideCursor;
       If MP > NPicks then MP := 1;
       If MP < 1 then MP := NPicks;
       Reverse(MP);
        {Paint new pick in reverse video}
       If LastMP <> MP then Restore(LastMP);
        {Restore last pick to original color}
       LastMP := MP;

       Ch := NextKey;
        {read a character}

       If not FunctKey then
        Case Ch of
           Enter  : ExitMenuPick := True;
           Escape : Begin
                     ExitMenuPick := True;
                     MP := NPicks;
                      {set Pick to last, exit}
                    End;
           '1'..'9',
           'a'..'z',
           'A'..'Z':Begin
                     NoMatch := true;
                     For II := 1 to NPicks do
                       If Upcase(Ch) = Capch[II] then
                       begin
                        MP := II;
                        Reverse(MP);
                        If LastMP <> MP
                         then Restore(LastMP);
                        LastMP := MP;
                        NoMatch := false;
                        ExitMenuPick := true;
                       end;
                     If NoMatch then beep(440);
                    End;
           Else Beep(440);
        End; {case ch}

       If FunctKey then
        Case Ch of
          RightArrow : MP := MP + 1;
          LeftArrow  : MP := MP - 1;
          DownArrow  : MP := MP + 1;
          UpArrow    : MP := MP - 1;
          Home       : MP := 1;
          EndKey     : MP := NPicks;
          Else Beep(440);
        End; {Case}

     Until ExitMenuPick;
   MenuPick := CapCh[MP];
END;
{=====================================================}
{                                                     }
{  Dummy procedure. Do not include in real            }
{  application.                                       }
{                                                     }
PROCEDURE TypeOnScreen;
VAR TCh : Char;
BEGIN
     SaveScreen(1);
     HelpContext := 2; {switch help screen}
     ClrScr;
     GoToXY(1,25);
     Write('Type stuff on screen, '+
     'hit F1 for help, Hit Esc. to Exit');
     GoToXY(1,1);
   Repeat
     TCh := NextKey;
     Write(TCh);
   Until TCh = #27;
     RestoreScreen(1);
END;

{=====================================================}
{                                                     }
{  Example main program                               }
{                                                     }
BEGIN
 BigExit := false;
 ShowMenu('EXMENU.MEM');
 HelpContext := 1;         {set help screen}
 Repeat Case MenuPick of
  'T' : Begin
         TypeOnScreen;
         HelpContext := 1; {switch back help screen}
        End;
  'L' : Beep(50);
  'H' : Beep(1000);
  'M' : Beep(300);
  '1' : Begin End;
  '2' : Begin End;
  'D' : Begin End;
  'E' : Begin End;
  'X' : BigExit := True;
   End; {case}
 Until BigExit;
 Clrscr;
END.