home *** CD-ROM | disk | FTP | other *** search
/ Power Programming / powerprogramming1994.iso / progtool / microcrn / issue_42.arc / PASCAL42.PAS < prev    next >
Pascal/Delphi Source File  |  1988-05-20  |  8KB  |  250 lines
  1. { Support code for Pascal Column from Micro C issue #42 }
  2.  
  3. { Listing 1 }
  4.  
  5. unit scrnmgr;
  6.  
  7. interface
  8. uses
  9.   crt,
  10.   dos;
  11.  
  12. type
  13.   window_rec = record
  14.     ulx, uly : byte;         { location of upper left corner }
  15.     xsize, ysize : byte;     { width and height of window }
  16.     save,                    { save underlying screen? }
  17.     clear,                   { clear new window? }
  18.     border : boolean;        { border around the window? }
  19.     fgcolor, bkgcolor : byte;{ foreground and background colors }
  20.   end;
  21.  
  22. var
  23.   saved_x, saved_y : byte;  { storage for current x,y cursor position }
  24.   mgr_ok : boolean;
  25.  
  26. procedure savescr;
  27. procedure restorescr;
  28. procedure clreos(wr:window_rec);
  29. procedure open_window(wr:window_rec);
  30. procedure error(line, column : byte; time:word; s:string;wr:window_rec);
  31.  
  32. implementation
  33.  
  34. type
  35.   screen = array[0..1999] of word;  { 25 lines of 80 chars + attributes }
  36.  
  37. const
  38.   ulc = #218;    { upper left corner char '┌'}
  39.   urc = #191;    { upper right corner char '┐'}
  40.   llc = #192;    { lower left corner char '└'}
  41.   lrc = #217;    { lower right corner char '┘'}
  42.   vbar = #179;   { vertical bar char '│' }
  43.   hbar = #196;   { horizontal bar char '─' }
  44.  
  45. var
  46.   videomode : byte;         { current video mode reported by BIOS }
  47.   savedscreen : ^screen;    { put saved physical screen in dynamic storage }
  48.   scrnseg : word;           { segment address of screen refresh memory }
  49.  
  50.  
  51. function setupscreen: boolean;
  52. { Initialize global variables and save area for current TEXT video mode.
  53.   The function returns FALSE if the BIOS reports a video mode not in the
  54.   known TEXT modes. }
  55. var
  56.   rr : registers;
  57. begin
  58.   rr.ah := $f;              { BIOS video function 15, report video mode }
  59.   intr($10,rr);
  60.   videomode := rr.al;       { current mode reported in AL }
  61.   setupscreen := true;      { assume videomode is OK }
  62.   case videomode of
  63.     0..6 : scrnseg := $b800; { one of the CGA text modes? }
  64.     7    : scrnseg := $b000; { monochrome text mode ? }
  65.     13,14,16 : scrnseg := $a800; { 13..16 are EGA modes }
  66.     15 : scrnseg := $a000;
  67.     else begin
  68.       setupscreen := false;  { not a valid text mode, let caller know }
  69.       exit;                  { don't allocate storage if invalid }
  70.     end;
  71.   end;
  72.   new(savedscreen);        { physical screen storage area }
  73.   window(1,1,80,25);       { full screen window for now }
  74.   textcolor(white);        { in defauld colors }
  75.   textbackground(black);
  76.   clrscr;                  { start with a fresh slate }
  77. end;
  78.  
  79. procedure savescr;
  80. { Save the physical screen and current cursor position.  It is assumed
  81.   that these values may be needed when the physical screen is later restored.
  82.   Note that the function setupscreen MUST have returned TRUE or the system
  83.   may crash. }
  84. begin
  85.   saved_x := wherex;
  86.   saved_y := wherey;
  87.   move(mem[scrnseg:0],savedscreen^,sizeof(screen));
  88. end;
  89.  
  90. procedure restorescr;
  91. { Restore a previously saved physical screen }
  92. begin
  93.   move(savedscreen^,mem[scrnseg:0],sizeof(screen));
  94. end;
  95.  
  96. procedure clreos(wr:window_rec);
  97. { Useful procedure not provided in the CRT unit, clear from current
  98.   cursor position to the end of the current window.  Cursor is left
  99.   (actually returned to) at the current position.
  100.   The window_rec passed as a parameter describes the currently active
  101.   window. }
  102. var
  103.   x, y, i : byte;
  104. begin
  105.   clreol;                     { clear tail of current line }
  106.   y := wherey;
  107.   x := wherex;
  108.   for i := y+1 to wr.ysize+1 do  { for next line to maxline }
  109.   begin
  110.     gotoxy(1,i);               { go to start of line }
  111.     clreol;                    { and clear it }
  112.   end;
  113.   gotoxy(x,y);                 { restore cursor }
  114. end;
  115.  
  116. procedure open_window(wr:window_rec);
  117. { Open (or reopen) a window.  If the underlying screen needs to be restored
  118.   when the window is 'closed' wr.save should be set TRUE.  If the window
  119.   opened needs to be cleared, set wr.clear TRUE and if you want a border
  120.   around the window, set wr.border TRUE.  No error checking is performed so
  121.   if any of the x or y values would overflow the physical screen results
  122.   will be unpredictable. }
  123. var
  124.   i, j : word;
  125.   x1,x2,y1,y2 : byte;
  126. begin
  127.   textcolor (wr.fgcolor);
  128.   textbackground(wr.bkgcolor);
  129.   if wr.save then savescr;
  130.   x1 := wr.ulx;
  131.   x2 := wr.ulx+wr.xsize;
  132.   y1 := wr.uly;
  133.   y2 := wr.uly+wr.ysize;
  134.   if wr.border then begin
  135.     window(1,1,80,25);
  136.     gotoxy(x1-1,y1-1);
  137.     write(ulc);
  138.     for i := x1 to x2 do write(hbar);
  139.     write (urc);
  140.     for i := y1 to y2 do
  141.     begin
  142.     gotoxy(x2+1,i);
  143.     write(vbar);
  144.     end;
  145.     for i := y1 to y2 do
  146.     begin
  147.     gotoxy(x1-1,i);
  148.       write(vbar);
  149.     end;
  150.     gotoxy(x1-1,y2+1);
  151.     write(llc);
  152.     for i := x1 to x2 do write(hbar);
  153.     write(lrc);
  154.   end;
  155.   window(x1,y1,x2,y2);
  156.   if wr.clear then clrscr;
  157. end;
  158.  
  159.  
  160. procedure error(line, column : byte; time:word; s:string;wr:window_rec);
  161. { Display an error message at physical column, line (flashing, reverse video)
  162.   then wait for either TIME seconds to expire, or for a keystroke.  The screen
  163.   area overlayed by the error message is saved on entry, restored on exit.
  164.   This routine opens a one line window for the error message, then restores
  165.   the window status passed in wr.  Only minimal error checking performed. }
  166. var
  167.   x,y : byte;
  168.   ch : char;
  169.   tt : longint;
  170.   temp : array[0..159] of byte;
  171. begin
  172.   x := wherex;         { save cursor position for caller }
  173.   y := wherey;
  174.   if length(s)+column+1 > 80 then exit; { restrict to one line }
  175.   dec(line);           { screen memory addresses are zero based }
  176.   dec(column);
  177.   tt := 0;             { local timer }
  178.   move(mem[scrnseg:line*160+column*2], temp, (length(s)*2)+4);
  179.      { save error area's data }
  180.   window(column+1,line+1,column+1+length(s)+1,line+1);
  181.   textbackground(wr.fgcolor);
  182.   clrscr;
  183.   textcolor(wr.bkgcolor+blink); { blinking reverse video }
  184.   write(s);
  185.   repeat
  186.     delay(250);        { each quarter second }
  187.     inc(tt);           { bump local timer }
  188.   until (tt div 4 > time) or keypressed;  { check for time up, or keystroke }
  189.   if keypressed then ch := readkey;
  190.   move(temp, mem[scrnseg:line*160+column*2], (length(s)*2)+4);
  191.      { restore physical screen data }
  192.   window(wr.ulx,wr.uly,wr.ulx+wr.xsize,wr.uly+wr.ysize);
  193.   textcolor(wr.fgcolor);
  194.   textbackground(wr.bkgcolor);
  195.      { restore caller's window }
  196.   gotoxy(x,y);
  197. end;
  198.  
  199. begin
  200.   mgr_ok := setupscreen;
  201. end.
  202.  
  203.  
  204.  
  205.  
  206.  
  207. { Listing 2 }
  208.  
  209. program test_mgr;
  210. uses
  211.   crt, scrnmgr;
  212. var
  213.   w1, w2 : window_rec;
  214.   a : word;
  215.   ch : char;
  216. begin
  217.   with w1 do begin
  218.     ulx := 5; uly := 5;
  219.     xsize := 25; ysize := 7;
  220.     fgcolor := green; bkgcolor := blue;
  221.     border := true; clear := true; save := true;
  222.   end;
  223.   with w2 do begin
  224.     ulx := 3; uly := 3;
  225.     xsize := 75; ysize := 20;
  226.     fgcolor := yellow; bkgcolor := cyan;
  227.     border := true; clear := true; save := false;
  228.   end;
  229.   if mgr_ok then begin
  230.     open_window(w2);
  231.     w2.clear := false; w2.border := false;
  232.     for a := 1 to 35 do
  233.       write('':a,'This is a test of window 2');
  234.     ch := readkey;
  235.     open_window(w1);
  236.     for a := 1 to 10 do
  237.       writeln('':a,'This is window 1.');
  238.     ch := readkey;
  239.     error(13,12,300,'This is an error message.',w1);
  240.     ch := readkey;
  241.     restorescr;
  242.     open_window(w2);
  243.     ch := readkey;
  244.     gotoxy(17,4);
  245.     clreos(w2);
  246.     ch := readkey;
  247.   end;
  248. end.
  249.  
  250.