Power-Programmierung/CD1.mdf/pascal/library/dos/menu/popups/popups.pas

Pascal/Delphi Source File | 1988-08-24 | 11.5 KB | 387 lines

UNIT POPUPS;

{ *Kent Porter DDJ  Jul '88 Pg. 122        * }
{ *Support for pop-up windows and menu bars* }
{ *Works with MDA, Compaq, CGA, EGA, & VGA * }
{ *Turbo Pascal 4.0                        * }

INTERFACE

USES dos, crt;

{*These are names for common keystrokes   *}

CONST F1           = #187;       {Sanyo, #195}
      F2           = #188;       {Sanyo, #200}
      F3           = #189;       {Sanyo, #211}
      F4           = #190;       {Sanyo, #210}
      F5           = #191;       {Sanyo, #198}
      HomeKey      = #199;       {Sanyo, #140}
      EndKey       = #207;       {Sanyo Code not known}
      PgUp         = #201;       {Sanyo Code not known}
      PgDn         = #209;       {Sanyo Code not known}
      UpCursor     = #200;       {Sanyo, #158}
      Downcursor   = #208;       {Sanyo, #159}
      LeftCursor   = #203;       {Sanyo, #156}
      RiteCursor   = #205;       {Sanyo, #157}
      Enter        = #13;

{*These are structures used by the routines *}

CONST SEP = '~';

TYPE
  strPtr = ^STRING;
  popRec = RECORD
    left, top, right, bottom,                     {Border locations}
      style,                     {Border style none, single, double}
      normal, hilite,                              {Text attributes}
      normback, hiback, border : Integer;
    contents : strPtr;                         {Fixed text contents}
    save : POINTER;                 {pointer to display save buffer}
    oldMin, oldMax :WORD;               {previous window dimensions}
    oldX, oldY :INTEGER;                 {previous cursor locations}
    oldColor : WORD;               {previous fore/background colors}
    END;

menuRec = RECORD
  row,                           {row where bar appears}
    interval,                    {cols between first chars}
    fore, back : INTEGER;        {fore/background colors}
  choice : strPtr;               {pointer to text contents}
  END;

VAR VideoBuffer : POINTER;        {Global pointer to Text video Buffer}

{*List of exported routines in this module*}
{* ---------------------------------------*}

PROCEDURE textbox (left, top, right, bottom, style : INTEGER);
PROCEDURE popShow (VAR pop : popRec);
PROCEDURE popErase (VAR pop : popRec);
PROCEDURE popCenter (VAR pop : popRec; row : INTEGER; info : STRING);
PROCEDURE popHilite (VAR pop : popRec; row : INTEGER);
PROCEDURE popNormal (VAR pop : popRec; row : INTEGER);
PROCEDURE showMenubar (VAR spec : menuRec);
PROCEDURE cursOff;
PROCEDURE cursOn;
FUNCTION  Keystroke : CHAR;

{* ----------------------------------------------------------------- *}

IMPLEMENTATION

{  Private Identifiers  }

CONST bufSize = 4096;                             {size of video buffer}
      border : ARRAY [1..2, 0..5] of CHAR =           {box border chars}
          (( #196, #179, #218, #191, #217, #192),
           ( #205, #186, #201, #187, #188, #200));

VAR   egaByte : WORD ABSOLUTE $0040:$0087;          {EGA equipment byte}
      reg     : REGISTERS;                    {regs for low level calls}
      mode    : WORD;                               {current video mode}

{ Routine bodies follow }

 PROCEDURE textbox;

           { Draw textbox in indicated style, where:
                 0 = no border
                 1 = single score
                 2 = double score }

VAR  r, c : INTEGER;

BEGIN
  If style IN [1..2] THEN BEGIN

    { Draw horizontals }
    FOR c := (left+1) TO right DO BEGIN
      Gotoxy (c, top);        WRITE (border [style, 0]);
      Gotoxy (c, bottom);     WRITE (border [style, 0]);
    END;

    { Draw verticals }
    FOR r := (top+1) To bottom DO BEGIN
         Gotoxy (left,r);     WRITE (border [style,1]);
         Gotoxy (right,r);    WRITE (border [style,1]);
       END;

    { Draw corners }

         Gotoxy (left, top);     WRITE (border [style, 2]);
         Gotoxy (right, top);    WRITE (border [style, 3]);
         Gotoxy (right, bottom); WRITE (border [style, 4]);
         Gotoxy (left, bottom);  WRITE (border [style, 5]);
       END;
    END; { of textbox }

    { *--------------------------* }

PROCEDURE popShow;

     { display popup described by passed structures }

  PROCEDURE popWrite (VAR winText : STRING);

       { Local proc. to write fixed popup contents, if any }

  VAR p : INTEGER;

  BEGIN
    IF pop.contents <> NIL THEN BEGIN
      GOTOXY (2, 1);
      FOR p := 1 TO length (winText) DO
        IF winText [p] <> SEP THEN
          WRITE (winText [p])
        ELSE
          GOTOXY (2, whereY + 1);   {Go to next row on separator }
    END;
  END;   { of popWrite }

BEGIN  { Body of popShow }

  {Get the current video state }
  pop.oldMin := windMin + $0101;
  pop.oldMax := windMax + $0101;                            {window dimensions}
  pop.oldColor := textAttr;                                   {current colors}
  pop.oldX := whereX; pop.oldY := whereY;                    {Cursor position}
  Window (1, 1, 80, 25);                        {rest window to entire screen}

  { Save the current screen }
  GetMem (pop.save, bufSize);                         {allocate space for it}
  Move (videoBuffer^, pop.save^, bufSize);                      {save screen}

  { Draw the border for the popup }
  WITH pop DO BEGIN
    Textcolor (border);
    Textbackground (normback);
    Textbox (left, top, right, bottom, style);

  { Open this window }
    Textcolor (normal);
    Window (left +1, top+1, right -1, bottom -1);
  END;  { of WITH }

  { Write fixed text }
  ClrScr;
  popWrite (pop.contents^);
  END;

{ *--------------------------* }
  PROCEDURE popErase;
        { Erase pop-up window, restoring overlaid image }

  BEGIN

    { Make sure there is a saved image to restore }
    IF pop.save <> NIL THEN BEGIN
     window (1, 1, 80, 25);

    { Restore previous video state }
      WITH pop DO BEGIN
        Window (LO (oldmin), HI (oldmin),
                LO (oldmax), HI (oldmax));
        Textcolor (oldColor and $0F);
        TextBackground (oldColor SHR 4);
        Gotoxy (pop.oldX, pop.oldY);
      END;
    { Restore overlaid screen image }
      Move (pop.save^, videoBuffer^, bufSize);
      FreeMem (pop.save,bufSize);
      pop.save :=NIL;
    END;
  END;

{ * ------------------------------------ * }

  PROCEDURE popCenter;

        { Center string in window at specified row }

  VAR  col : INTEGER;

  BEGIN
    IF pop.save <> NIL THEN                          { pop-up is visible }
      IF row < pop.bottom - pop.top  THEN BEGIN           { row is legal }

      col := (pop.right - pop.left - Length (info)) DIV 2;
      GotoXY (col, row);
      WRITE (info);
    END;
  END;

{* -------------------------- *}
PROCEDURE popRewrite  (VAR pop : popRec; row : INTEGER; attrib : BYTE);
      { Local proc. called by popHilite and popNormal    }
      { Rewrites pop-up row with new character attribute }

VAR p, nchars : INTEGER;

BEGIN

  IF pop.save <> NIL THEN                       { pop-up is visible }
    IF row < pop.bottom - pop.top THEN BEGIN
      nchars := pop.right - pop.left - 1;       { Get width of row  }
      FOR p := 1 TO nchars DO BEGIN     { For each char in row do.. }
      Gotoxy (p, row);                                  { goto char }
      reg.ah := 8;                                       { get char }
      reg.bh := 0;
      intr (16, reg);                                { via ROM BIOS }
      reg.ah := 9;                             { write backout with }
      reg.bl := attrib;                             { hilite attrib }
      reg.bh := 0;
      reg.cx := 1;
      intr (16, reg);
    END;
  END;
END;

{ * ---------------------------------- * }

PROCEDURE popHilite;

      { Highlight text in specified pop-up row }

VAR  attrib : BYTE;
     x, y   : INTEGER;

BEGIN
  x := whereX; y := whereY;                      { Save cursor position }
  attrib  := pop.hilite + (pop.hiback SHL 4);     { Set text attributes }
  popRewrite  (pop, row, attrib);                         { Rewrite row }
  GotoXY (x, y);                                       { Restore cursor }
END;

{* -------------------------- *}

PROCEDURE popNormal;

      { Set text in pop-up row to normal attributes }

VAR  attrib : BYTE;
     x, y   : INTEGER;

BEGIN
  x := whereX; y := whereY;
  attrib := pop.normal + (pop.normback SHL 4);
  popRewrite (pop, row, attrib);
  GotoXY (x, y);
END;

PROCEDURE menuBar;
  BEGIN
  END;

{* -------------------------- *}

PROCEDURE showMenubar;

     { Place menu bar in current window }

VAR  p, c, color, curX, curY : INTEGER;
     x1, x2                  : INTEGER;

BEGIN

  { Save video state information }
  curX := whereX; curY := whereY;
  color := TextAttr;
  x1    := Lo (WindMin);
  x2    := Lo (WindMax);

  { Set colors for menu }
  TextColor (spec.fore);
  TextBackground (spec.back);
  GotoXY (1, spec.row);
  WRITELN (' ');

  { Write out the bar background first }

  GotoXY (1, spec.row);
  FOR p := x1 TO x2 DO
    WRITE  (' ');

  { Write the menu bar text }
  GotoXY (1, spec.row);                             { First item location }
  c := 1;                                                  { Item counter }
  FOR p := 1 TO Length (spec.choice^) DO BEGIN             { Char by char }
    IF spec.choice^[p] <>  SEP THEN                    { If not delimiter }
      WRITE (spec.choice^[p])                                 { Write char }
    ELSE BEGIN                                                     { Else }
      GotoXY ((spec.interval * c) * 1 , spec.row);      { Go to next item }
      INC (c);                                              { Count items }
    END;
  END;

  { Restore video state }
  TextColor (color AND $0F);
  TextBackground (color SHR 4);
  GotoXY (curX, curY);
END;

{* -------------------------- *}

PROCEDURE cursOff;

      { Turn off hardware cursor }

BEGIN
  reg.ah := 3;                                    { get current cursor shape }
  reg.bh := 0;                                  { Note: works in page 0 only }
  Intr (16, reg);
  reg.ch := reg.ch OR $20;                                   { Turn on bit 5 }
  reg.ah := 1;
  Intr (16, reg);
END;

{* -------------------------- *}

PROCEDURE cursOn;

      { Turn hardware cursor back on }

BEGIN
  reg.ah := 3;                                   { As above except }
  reg.bh := 0;
  Intr (16, reg);
  reg.ch := reg.ch AND $DF;                       { Turn off bit 5 }
  reg.ah := 1;
  Intr (16, reg);
END;

{* -------------------------- *}

FUNCTION Keystroke;

      { Wait for a keystroke. If it's a special key  (0+code), }
      { return the second byte + 128, else return upper case }

VAR ch :CHAR;

BEGIN
  ch := UpCase (ReadKey);                                 { Get keystroke }
  IF ch  = chr (0) THEN BEGIN                     { If a lead-in then ... }
    ch := ReadKey;                                  { the second byte and }
    ch := chr (ord (ch) + 128);                         { shift up by 128 }
  END;
  Keystroke := ch;
END;

{* ------------------------------------------------------------ *}

{ INITIALIZATION CODE SETS ADDRESS OF VIDEO BUFFER }

BEGIN
     reg.ah := 15;                                { Get current video mode }
     Intr (16, reg);
     mode := reg.al;

     IF (mode = 7) or (mode = 2) THEN             { Either MDA or Compaq MDA }
       videoBuffer := ptr ($B000, $0000)
     ELSE
       videoBuffer := ptr ($B800, $0000)                 { Else color buffer }
END.      { of unit POPUPS.PAS }