home *** CD-ROM | disk | FTP | other *** search
/ Power Programming / powerprogramming1994.iso / progtool / turbopas / tppopups.arc / POPUPS.PAS < prev    next >
Pascal/Delphi Source File  |  1988-08-24  |  12KB  |  387 lines
  1. UNIT POPUPS;
  2.  
  3. { *Kent Porter DDJ  Jul '88 Pg. 122        * }
  4. { *Support for pop-up windows and menu bars* }
  5. { *Works with MDA, Compaq, CGA, EGA, & VGA * }
  6. { *Turbo Pascal 4.0                        * }
  7.  
  8. INTERFACE
  9.  
  10. USES dos, crt;
  11.  
  12. {*These are names for common keystrokes   *}
  13.  
  14. CONST F1           = #187;       {Sanyo, #195}
  15.       F2           = #188;       {Sanyo, #200}
  16.       F3           = #189;       {Sanyo, #211}
  17.       F4           = #190;       {Sanyo, #210}
  18.       F5           = #191;       {Sanyo, #198}
  19.       HomeKey      = #199;       {Sanyo, #140}
  20.       EndKey       = #207;       {Sanyo Code not known}
  21.       PgUp         = #201;       {Sanyo Code not known}
  22.       PgDn         = #209;       {Sanyo Code not known}
  23.       UpCursor     = #200;       {Sanyo, #158}
  24.       Downcursor   = #208;       {Sanyo, #159}
  25.       LeftCursor   = #203;       {Sanyo, #156}
  26.       RiteCursor   = #205;       {Sanyo, #157}
  27.       Enter        = #13;
  28.  
  29. {*These are structures used by the routines *}
  30.  
  31. CONST SEP = '~';
  32.  
  33. TYPE
  34.   strPtr = ^STRING;
  35.   popRec = RECORD
  36.     left, top, right, bottom,                     {Border locations}
  37.       style,                     {Border style none, single, double}
  38.       normal, hilite,                              {Text attributes}
  39.       normback, hiback, border : Integer;
  40.     contents : strPtr;                         {Fixed text contents}
  41.     save : POINTER;                 {pointer to display save buffer}
  42.     oldMin, oldMax :WORD;               {previous window dimensions}
  43.     oldX, oldY :INTEGER;                 {previous cursor locations}
  44.     oldColor : WORD;               {previous fore/background colors}
  45.     END;
  46.  
  47. menuRec = RECORD
  48.   row,                           {row where bar appears}
  49.     interval,                    {cols between first chars}
  50.     fore, back : INTEGER;        {fore/background colors}
  51.   choice : strPtr;               {pointer to text contents}
  52.   END;
  53.  
  54. VAR VideoBuffer : POINTER;        {Global pointer to Text video Buffer}
  55.  
  56. {*List of exported routines in this module*}
  57. {* ---------------------------------------*}
  58.  
  59. PROCEDURE textbox (left, top, right, bottom, style : INTEGER);
  60. PROCEDURE popShow (VAR pop : popRec);
  61. PROCEDURE popErase (VAR pop : popRec);
  62. PROCEDURE popCenter (VAR pop : popRec; row : INTEGER; info : STRING);
  63. PROCEDURE popHilite (VAR pop : popRec; row : INTEGER);
  64. PROCEDURE popNormal (VAR pop : popRec; row : INTEGER);
  65. PROCEDURE showMenubar (VAR spec : menuRec);
  66. PROCEDURE cursOff;
  67. PROCEDURE cursOn;
  68. FUNCTION  Keystroke : CHAR;
  69.  
  70. {* ----------------------------------------------------------------- *}
  71.  
  72. IMPLEMENTATION
  73.  
  74. {  Private Identifiers  }
  75.  
  76. CONST bufSize = 4096;                             {size of video buffer}
  77.       border : ARRAY [1..2, 0..5] of CHAR =           {box border chars}
  78.           (( #196, #179, #218, #191, #217, #192),
  79.            ( #205, #186, #201, #187, #188, #200));
  80.  
  81. VAR   egaByte : WORD ABSOLUTE $0040:$0087;          {EGA equipment byte}
  82.       reg     : REGISTERS;                    {regs for low level calls}
  83.       mode    : WORD;                               {current video mode}
  84.  
  85. { Routine bodies follow }
  86.  
  87.  PROCEDURE textbox;
  88.  
  89.            { Draw textbox in indicated style, where:
  90.                  0 = no border
  91.                  1 = single score
  92.                  2 = double score }
  93.  
  94. VAR  r, c : INTEGER;
  95.  
  96. BEGIN
  97.   If style IN [1..2] THEN BEGIN
  98.  
  99.     { Draw horizontals }
  100.     FOR c := (left+1) TO right DO BEGIN
  101.       Gotoxy (c, top);        WRITE (border [style, 0]);
  102.       Gotoxy (c, bottom);     WRITE (border [style, 0]);
  103.     END;
  104.  
  105.     { Draw verticals }
  106.     FOR r := (top+1) To bottom DO BEGIN
  107.          Gotoxy (left,r);     WRITE (border [style,1]);
  108.          Gotoxy (right,r);    WRITE (border [style,1]);
  109.        END;
  110.  
  111.     { Draw corners }
  112.  
  113.          Gotoxy (left, top);     WRITE (border [style, 2]);
  114.          Gotoxy (right, top);    WRITE (border [style, 3]);
  115.          Gotoxy (right, bottom); WRITE (border [style, 4]);
  116.          Gotoxy (left, bottom);  WRITE (border [style, 5]);
  117.        END;
  118.     END; { of textbox }
  119.  
  120.     { *--------------------------* }
  121.  
  122. PROCEDURE popShow;
  123.  
  124.      { display popup described by passed structures }
  125.  
  126.   PROCEDURE popWrite (VAR winText : STRING);
  127.  
  128.        { Local proc. to write fixed popup contents, if any }
  129.  
  130.   VAR p : INTEGER;
  131.  
  132.   BEGIN
  133.     IF pop.contents <> NIL THEN BEGIN
  134.       GOTOXY (2, 1);
  135.       FOR p := 1 TO length (winText) DO
  136.         IF winText [p] <> SEP THEN
  137.           WRITE (winText [p])
  138.         ELSE
  139.           GOTOXY (2, whereY + 1);   {Go to next row on separator }
  140.     END;
  141.   END;   { of popWrite }
  142.  
  143. BEGIN  { Body of popShow }
  144.  
  145.   {Get the current video state }
  146.   pop.oldMin := windMin + $0101;
  147.   pop.oldMax := windMax + $0101;                            {window dimensions}
  148.   pop.oldColor := textAttr;                                   {current colors}
  149.   pop.oldX := whereX; pop.oldY := whereY;                    {Cursor position}
  150.   Window (1, 1, 80, 25);                        {rest window to entire screen}
  151.  
  152.   { Save the current screen }
  153.   GetMem (pop.save, bufSize);                         {allocate space for it}
  154.   Move (videoBuffer^, pop.save^, bufSize);                      {save screen}
  155.  
  156.   { Draw the border for the popup }
  157.   WITH pop DO BEGIN
  158.     Textcolor (border);
  159.     Textbackground (normback);
  160.     Textbox (left, top, right, bottom, style);
  161.  
  162.   { Open this window }
  163.     Textcolor (normal);
  164.     Window (left +1, top+1, right -1, bottom -1);
  165.   END;  { of WITH }
  166.  
  167.   { Write fixed text }
  168.   ClrScr;
  169.   popWrite (pop.contents^);
  170.   END;
  171.  
  172. { *--------------------------* }
  173.   PROCEDURE popErase;
  174.         { Erase pop-up window, restoring overlaid image }
  175.  
  176.   BEGIN
  177.  
  178.     { Make sure there is a saved image to restore }
  179.     IF pop.save <> NIL THEN BEGIN
  180.      window (1, 1, 80, 25);
  181.  
  182.     { Restore previous video state }
  183.       WITH pop DO BEGIN
  184.         Window (LO (oldmin), HI (oldmin),
  185.                 LO (oldmax), HI (oldmax));
  186.         Textcolor (oldColor and $0F);
  187.         TextBackground (oldColor SHR 4);
  188.         Gotoxy (pop.oldX, pop.oldY);
  189.       END;
  190.     { Restore overlaid screen image }
  191.       Move (pop.save^, videoBuffer^, bufSize);
  192.       FreeMem (pop.save,bufSize);
  193.       pop.save :=NIL;
  194.     END;
  195.   END;
  196.  
  197. { * ------------------------------------ * }
  198.  
  199.   PROCEDURE popCenter;
  200.  
  201.         { Center string in window at specified row }
  202.  
  203.   VAR  col : INTEGER;
  204.  
  205.   BEGIN
  206.     IF pop.save <> NIL THEN                          { pop-up is visible }
  207.       IF row < pop.bottom - pop.top  THEN BEGIN           { row is legal }
  208.  
  209.       col := (pop.right - pop.left - Length (info)) DIV 2;
  210.       GotoXY (col, row);
  211.       WRITE (info);
  212.     END;
  213.   END;
  214.  
  215. {* -------------------------- *}
  216. PROCEDURE popRewrite  (VAR pop : popRec; row : INTEGER; attrib : BYTE);
  217.       { Local proc. called by popHilite and popNormal    }
  218.       { Rewrites pop-up row with new character attribute }
  219.  
  220. VAR p, nchars : INTEGER;
  221.  
  222. BEGIN
  223.  
  224.   IF pop.save <> NIL THEN                       { pop-up is visible }
  225.     IF row < pop.bottom - pop.top THEN BEGIN
  226.       nchars := pop.right - pop.left - 1;       { Get width of row  }
  227.       FOR p := 1 TO nchars DO BEGIN     { For each char in row do.. }
  228.       Gotoxy (p, row);                                  { goto char }
  229.       reg.ah := 8;                                       { get char }
  230.       reg.bh := 0;
  231.       intr (16, reg);                                { via ROM BIOS }
  232.       reg.ah := 9;                             { write backout with }
  233.       reg.bl := attrib;                             { hilite attrib }
  234.       reg.bh := 0;
  235.       reg.cx := 1;
  236.       intr (16, reg);
  237.     END;
  238.   END;
  239. END;
  240.  
  241. { * ---------------------------------- * }
  242.  
  243. PROCEDURE popHilite;
  244.  
  245.       { Highlight text in specified pop-up row }
  246.  
  247. VAR  attrib : BYTE;
  248.      x, y   : INTEGER;
  249.  
  250. BEGIN
  251.   x := whereX; y := whereY;                      { Save cursor position }
  252.   attrib  := pop.hilite + (pop.hiback SHL 4);     { Set text attributes }
  253.   popRewrite  (pop, row, attrib);                         { Rewrite row }
  254.   GotoXY (x, y);                                       { Restore cursor }
  255. END;
  256.  
  257. {* -------------------------- *}
  258.  
  259. PROCEDURE popNormal;
  260.  
  261.       { Set text in pop-up row to normal attributes }
  262.  
  263. VAR  attrib : BYTE;
  264.      x, y   : INTEGER;
  265.  
  266. BEGIN
  267.   x := whereX; y := whereY;
  268.   attrib := pop.normal + (pop.normback SHL 4);
  269.   popRewrite (pop, row, attrib);
  270.   GotoXY (x, y);
  271. END;
  272.  
  273. PROCEDURE menuBar;
  274.   BEGIN
  275.   END;
  276.  
  277. {* -------------------------- *}
  278.  
  279. PROCEDURE showMenubar;
  280.  
  281.      { Place menu bar in current window }
  282.  
  283. VAR  p, c, color, curX, curY : INTEGER;
  284.      x1, x2                  : INTEGER;
  285.  
  286. BEGIN
  287.  
  288.   { Save video state information }
  289.   curX := whereX; curY := whereY;
  290.   color := TextAttr;
  291.   x1    := Lo (WindMin);
  292.   x2    := Lo (WindMax);
  293.  
  294.   { Set colors for menu }
  295.   TextColor (spec.fore);
  296.   TextBackground (spec.back);
  297.   GotoXY (1, spec.row);
  298.   WRITELN (' ');
  299.  
  300.   { Write out the bar background first }
  301.  
  302.   GotoXY (1, spec.row);
  303.   FOR p := x1 TO x2 DO
  304.     WRITE  (' ');
  305.  
  306.   { Write the menu bar text }
  307.   GotoXY (1, spec.row);                             { First item location }
  308.   c := 1;                                                  { Item counter }
  309.   FOR p := 1 TO Length (spec.choice^) DO BEGIN             { Char by char }
  310.     IF spec.choice^[p] <>  SEP THEN                    { If not delimiter }
  311.       WRITE (spec.choice^[p])                                 { Write char }
  312.     ELSE BEGIN                                                     { Else }
  313.       GotoXY ((spec.interval * c) * 1 , spec.row);      { Go to next item }
  314.       INC (c);                                              { Count items }
  315.     END;
  316.   END;
  317.  
  318.   { Restore video state }
  319.   TextColor (color AND $0F);
  320.   TextBackground (color SHR 4);
  321.   GotoXY (curX, curY);
  322. END;
  323.  
  324. {* -------------------------- *}
  325.  
  326. PROCEDURE cursOff;
  327.  
  328.       { Turn off hardware cursor }
  329.  
  330. BEGIN
  331.   reg.ah := 3;                                    { get current cursor shape }
  332.   reg.bh := 0;                                  { Note: works in page 0 only }
  333.   Intr (16, reg);
  334.   reg.ch := reg.ch OR $20;                                   { Turn on bit 5 }
  335.   reg.ah := 1;
  336.   Intr (16, reg);
  337. END;
  338.  
  339. {* -------------------------- *}
  340.  
  341. PROCEDURE cursOn;
  342.  
  343.       { Turn hardware cursor back on }
  344.  
  345. BEGIN
  346.   reg.ah := 3;                                   { As above except }
  347.   reg.bh := 0;
  348.   Intr (16, reg);
  349.   reg.ch := reg.ch AND $DF;                       { Turn off bit 5 }
  350.   reg.ah := 1;
  351.   Intr (16, reg);
  352. END;
  353.  
  354. {* -------------------------- *}
  355.  
  356. FUNCTION Keystroke;
  357.  
  358.       { Wait for a keystroke. If it's a special key  (0+code), }
  359.       { return the second byte + 128, else return upper case }
  360.  
  361. VAR ch :CHAR;
  362.  
  363. BEGIN
  364.   ch := UpCase (ReadKey);                                 { Get keystroke }
  365.   IF ch  = chr (0) THEN BEGIN                     { If a lead-in then ... }
  366.     ch := ReadKey;                                  { the second byte and }
  367.     ch := chr (ord (ch) + 128);                         { shift up by 128 }
  368.   END;
  369.   Keystroke := ch;
  370. END;
  371.  
  372. {* ------------------------------------------------------------ *}
  373.  
  374. { INITIALIZATION CODE SETS ADDRESS OF VIDEO BUFFER }
  375.  
  376. BEGIN
  377.      reg.ah := 15;                                { Get current video mode }
  378.      Intr (16, reg);
  379.      mode := reg.al;
  380.  
  381.      IF (mode = 7) or (mode = 2) THEN             { Either MDA or Compaq MDA }
  382.        videoBuffer := ptr ($B000, $0000)
  383.      ELSE
  384.        videoBuffer := ptr ($B800, $0000)                 { Else color buffer }
  385. END.      { of unit POPUPS.PAS }
  386.  
  387.