home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1988 / 07 / popups / popups.pas < prev   
Pascal/Delphi Source File  |  1988-05-23  |  11KB  |  388 lines
  1. «LM10»«AL1»«RHA
  2. «VA$fi»     «DAmm/dd/yy»     «TM»     Galley «PN» of «FP»
  3.  
  4. »«PT1»
  5. UNIT popups;
  6.  
  7. (* Kent Porter, DDJ, July '88 issue         *)
  8. (* Support for pop-up windows and menu bars *)
  9. (* Works with MDA, Compaq, CGA, EGA, VGA    *)
  10. (* Turbo Pascal 4.0                         *)
  11.  
  12. INTERFACE
  13.  
  14. USES dos, crt;
  15.  
  16. (* These are names for common keystrokes *)
  17.  
  18. CONST  F1         = #187;                     { Second byte plus 128 }
  19.        HomeKey    = #199;
  20.        EndKey     = #207;
  21.        PgUp       = #201;
  22.        PgDn       = #209;
  23.        UpCursor   = #200;
  24.        DownCursor = #208;
  25.        LeftCursor = #203;
  26.        RiteCursor = #205;
  27.        Enter      =  #13;
  28.  
  29. (* These are structures used by the routines *)
  30.  
  31. CONST  SEP = '~';               { Element separator in menu contents }
  32.  
  33. TYPE
  34.   strPtr = ^STRING;
  35.   popRec = RECORD
  36.     left, top, right, bottom,                     { Border locations }
  37.       style,                                          { Border style }
  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 location }
  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 eqpt 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.     Gotoxy (left, top);     WRITE (border [style, 2]);
  113.     Gotoxy (right, top);    WRITE (border [style, 3]);
  114.     Gotoxy (right, bottom); WRITE (border [style, 4]);
  115.     Gotoxy (left, bottom);  WRITE (border [style, 5]);
  116.   END;
  117. END;      { of textbox }
  118.  
  119. (* -------------------------- *)
  120.  
  121. PROCEDURE popShow;
  122.  
  123.      { display popup described by passed structure }
  124.  
  125.   PROCEDURE popWrite (VAR winText : STRING);
  126.  
  127.       { Local proc to write fixed popup contents, if any }
  128.  
  129.   VAR  p : INTEGER;
  130.  
  131.   BEGIN
  132.     IF pop.contents <> NIL THEN BEGIN
  133.       GOTOXY (2, 1);                  { Always leave 1 leading space }
  134.       FOR p := 1 TO length (winText) DO
  135.         IF winText [p] <> SEP THEN
  136.           WRITE (winText [p])
  137.         ELSE
  138.           GOTOXY (2, whereY + 1);      { Go to next row on separator }
  139.     END;
  140.   END;   { of popWrite }
  141.  
  142. BEGIN { Body of popShow }
  143.  
  144.   { Get the current video state }
  145.   pop.oldMin := windMin + $0101;
  146.   pop.oldMax := windMax + $0101;                 { window dimensions }
  147.   pop.oldColor := textAttr;                         { current colors }
  148.   pop.oldX := whereX; pop.oldY := whereY;          { cursor position }
  149.   Window (1, 1, 80, 25);               { reset window to full screen }
  150.  
  151.   { Save the current screen }
  152.   GetMem (pop.save, bufSize);                { allocate space for it }
  153.   Move (videoBuffer^, pop.save^, bufSize);             { save screen }
  154.  
  155.   { Draw the border for the popup }
  156.   WITH pop DO BEGIN
  157.     Textcolor (border);
  158.     Textbackground (normback);
  159.     Textbox (left, top, right, bottom, style);
  160.  
  161.   { Open the window }
  162.     Textcolor (normal);
  163.     Window (left+1, top+1, right-1, bottom-1);
  164.   END;   { of WITH }
  165.  
  166.   { Write fixed text }
  167.   ClrScr;
  168.   popWrite (pop.contents^);
  169. END;
  170.  
  171. (* -------------------------- *)
  172.  
  173. PROCEDURE popErase;
  174.  
  175.       { Erase pop-up window, restoring overlaid image }
  176.  
  177. BEGIN
  178.  
  179.   { Make sure there's a saved image to restore }
  180.   IF pop.save <> NIL THEN BEGIN
  181.     window (1, 1, 80, 25);
  182.  
  183.   { Restore previous video state }
  184.     WITH pop DO BEGIN
  185.       Window (LO (oldMin), HI (oldMin),
  186.               LO (oldMax), HI (oldMax));
  187.       Textcolor (oldColor AND $0F);
  188.       TextBackground (oldColor SHR 4);
  189.       Gotoxy (pop.oldX, pop.oldY);
  190.     END;
  191.  
  192.   { Restore overlaid screen image }
  193.     Move (pop.save^, videoBuffer^, bufSize);
  194.     FreeMem (pop.save, bufSize);
  195.     pop.save := NIL;
  196.   END;
  197. END;
  198.  
  199. (* -------------------------- *)
  200.  
  201. PROCEDURE popCenter;
  202.  
  203.       { Center string in window at specified row }
  204.  
  205. VAR   col : INTEGER;
  206.  
  207. BEGIN
  208.   IF pop.save <> NIL THEN                        { pop-up is visible }
  209.     IF row < pop.bottom - pop.top THEN BEGIN          { row is legal }
  210.       col := (pop.right - pop.left - Length (info)) DIV 2;
  211.       Gotoxy (col, row);
  212.       WRITE (info);
  213.     END;
  214. END;
  215.  
  216. (* -------------------------- *)
  217.  
  218. PROCEDURE popRewrite (VAR pop : popRec; row : INTEGER; attrib : BYTE);
  219.  
  220.       { Local proc called by popHilite and popNormal     }
  221.       { Rewrites pop-up row with new character attribute }
  222.  
  223. VAR  p, nchars : INTEGER;
  224.  
  225. BEGIN
  226.  
  227.   IF pop.save <> NIL THEN                        { pop-up is visible }
  228.     IF row < pop.bottom - pop.top THEN BEGIN
  229.       nchars := pop.right - pop.left - 1;         { Get width of row }
  230.       FOR p := 1 TO nchars DO BEGIN      { For each char in row do.. }
  231.         Gotoxy (p, row);                                 { goto char }
  232.         reg.ah := 8;                                      { Get char }
  233.         reg.bh := 0;
  234.         intr (16, reg);                               { via ROM BIOS }
  235.         reg.ah := 9;                           { write back out with }
  236.         reg.bl := attrib;                           { hilite attribs }
  237.         reg.bh := 0;
  238.         reg.cx := 1;
  239.         intr (16, reg);
  240.       END;
  241.     END;
  242. END;
  243.  
  244. (* -------------------------- *)
  245.  
  246. PROCEDURE popHilite;
  247.  
  248.       { Highlight text in specified pop-up row }
  249.  
  250. VAR   attrib : BYTE;
  251.       x, y   : INTEGER;
  252.  
  253. BEGIN
  254.   x := whereX; y := whereY;                   { Save cursor position }
  255.   Attrib := pop.hilite + (pop.hiback SHL 4);   { Set text attributes }
  256.   popRewrite (pop, row, attrib);                       { Rewrite row }
  257.   gotoxy (x, y);                                    { Restore cursor }
  258. END;
  259.  
  260. (* -------------------------- *)
  261.  
  262. PROCEDURE popNormal;
  263.  
  264.       { Set text in pop-up row to normal attributes }
  265.  
  266. VAR   attrib : BYTE;
  267.       x, y   : INTEGER;
  268.  
  269. BEGIN
  270.   x := whereX; y := whereY;
  271.   Attrib := pop.normal + (pop.normback SHL 4);
  272.   popRewrite (pop, row, attrib);
  273.   gotoxy (x, y);
  274. END;
  275.  
  276. PROCEDURE menuBar;
  277. BEGIN
  278. END;
  279.  
  280. (* -------------------------- *)
  281.  
  282. PROCEDURE showMenubar;
  283.  
  284.       { Place menu bar in current window }
  285.  
  286. VAR    p, c, color, curX, curY : INTEGER;
  287.        x1, x2                  : INTEGER;
  288.  
  289. BEGIN
  290.  
  291.   { Save video state information }
  292.   curX := whereX; curY := whereY;
  293.   color := TextAttr;
  294.   x1 := Lo (WindMin);
  295.   x2 := Lo (WindMax);
  296.  
  297.   { Set colors for menu }
  298.   TextColor (spec.fore);
  299.   TextBackground (spec.back);
  300.   gotoxy (1, spec.row);
  301.   WRITELN (' ');
  302.  
  303.   { Write out the bar background first }
  304.   Gotoxy (1, spec.row);
  305.   FOR p := x1 TO x2 DO
  306.     WRITE (' ');
  307.  
  308.   { Write the menubar text }
  309.   Gotoxy (1, spec.row);                        { First item location }
  310.   c := 1;                                             { Item counter }
  311.   FOR p := 1 TO Length (spec.choice^) DO BEGIN        { Char by char }
  312.     IF spec.choice^[p] <> SEP THEN                   { If not delim, }
  313.       WRITE (spec.choice^[p])                           { write char }
  314.     ELSE BEGIN                                                { else }
  315.       Gotoxy ((spec.interval * c) + 1, spec.row);  { Go to next item }
  316.       INC (c);                                         { Count items }
  317.     END
  318.   END;
  319.  
  320.   { Restore video state }
  321.   TextColor (color AND $0F);
  322.   TextBackground (color SHR 4);
  323.   Gotoxy (curX, curY);
  324. END;
  325.  
  326. (* -------------------------- *)
  327.  
  328. PROCEDURE cursOff;
  329.  
  330.       { Turn off hardware cursor }
  331.  
  332. BEGIN
  333.   reg.ah := 3;                            { get current cursor shape }
  334.   reg.bh := 0;                          { NOTE: works in page 0 only }
  335.   Intr (16, reg);
  336.   reg.ch := reg.ch OR $20;                           { turn on bit 5 }
  337.   reg.ah := 1;
  338.   Intr (16, reg);                                        { tell BIOS }
  339. END;
  340.  
  341. (* -------------------------- *)
  342.  
  343. PROCEDURE cursOn;
  344.  
  345.       { Turn hardware cursor back on }
  346.  
  347. BEGIN
  348.   reg.ah := 3;                                    { As above, except }
  349.   reg.bh := 0;
  350.   Intr (16, reg);
  351.   reg.ch := reg.ch AND $DF;                         { turn off bit 5 }
  352.   reg.ah := 1;
  353.   Intr (16, reg);
  354. END;
  355.  
  356. (* -------------------------- *)
  357.  
  358. FUNCTION Keystroke;
  359.  
  360.       { Wait for a keystroke. If it's a special key (0+code), }
  361.       { return the second byte + 128, else return upper case  }
  362.  
  363. VAR   ch : CHAR;
  364.  
  365. BEGIN
  366.   ch := UpCase (ReadKey);                            { Get keystroke }
  367.   IF ch = chr (0) THEN BEGIN                 { if a lead-in, then... }
  368.     ch := ReadKey;                         { get the second byte and }
  369.     ch := chr (ord (ch) + 128);                    { shift up by 128 }
  370.   END;
  371.   Keystroke := ch;
  372. END;
  373.  
  374. (* ---------------------------------------------------------------- *)
  375.  
  376. { INITIALIZATION CODE SETS ADDRESS OF VIDEO BUFFER }
  377.  
  378. Begin
  379.     Reg.ah := 15;                           { Get current video mode }
  380.     Intr (16, reg);
  381.     mode := reg.al;
  382.  
  383.     IF (mode = 7) OR (mode = 2) THEN      { Either MDA or Compaq MDA }
  384.       videoBuffer := ptr ($B000, $0000)
  385.     ELSE
  386.       videoBuffer := ptr ($B800, $0000);         { else color buffer }
  387. END.     { of unit POPUPS.PAS }
  388.