Category : Files from Magazines
Archive   : ISSUE-42.ZIP
Filename : PASCAL42.PAS

{ Support code for Pascal Column from Micro C issue #42 }

{ Listing 1 }

unit scrnmgr;

interface
uses
crt,
dos;

type
window_rec = record
ulx, uly : byte; { location of upper left corner }
xsize, ysize : byte; { width and height of window }
save, { save underlying screen? }
clear, { clear new window? }
border : boolean; { border around the window? }
fgcolor, bkgcolor : byte;{ foreground and background colors }
end;

var
saved_x, saved_y : byte; { storage for current x,y cursor position }
mgr_ok : boolean;

procedure savescr;
procedure restorescr;
procedure clreos(wr:window_rec);
procedure open_window(wr:window_rec);
procedure error(line, column : byte; time:word; s:string;wr:window_rec);

implementation

type
screen = array[0..1999] of word; { 25 lines of 80 chars + attributes }

const
ulc = #218; { upper left corner char 'Ú'}
urc = #191; { upper right corner char '¿'}
llc = #192; { lower left corner char 'À'}
lrc = #217; { lower right corner char 'Ù'}
vbar = #179; { vertical bar char '³' }
hbar = #196; { horizontal bar char 'Ä' }

var
videomode : byte; { current video mode reported by BIOS }
savedscreen : ^screen; { put saved physical screen in dynamic storage }
scrnseg : word; { segment address of screen refresh memory }


function setupscreen: boolean;
{ Initialize global variables and save area for current TEXT video mode.
The function returns FALSE if the BIOS reports a video mode not in the
known TEXT modes. }
var
rr : registers;
begin
rr.ah := $f; { BIOS video function 15, report video mode }
intr($10,rr);
videomode := rr.al; { current mode reported in AL }
setupscreen := true; { assume videomode is OK }
case videomode of
0..6 : scrnseg := $b800; { one of the CGA text modes? }
7 : scrnseg := $b000; { monochrome text mode ? }
13,14,16 : scrnseg := $a800; { 13..16 are EGA modes }
15 : scrnseg := $a000;
else begin
setupscreen := false; { not a valid text mode, let caller know }
exit; { don't allocate storage if invalid }
end;
end;
new(savedscreen); { physical screen storage area }
window(1,1,80,25); { full screen window for now }
textcolor(white); { in defauld colors }
textbackground(black);
clrscr; { start with a fresh slate }
end;

procedure savescr;
{ Save the physical screen and current cursor position. It is assumed
that these values may be needed when the physical screen is later restored.
Note that the function setupscreen MUST have returned TRUE or the system
may crash. }
begin
saved_x := wherex;
saved_y := wherey;
move(mem[scrnseg:0],savedscreen^,sizeof(screen));
end;

procedure restorescr;
{ Restore a previously saved physical screen }
begin
move(savedscreen^,mem[scrnseg:0],sizeof(screen));
end;

procedure clreos(wr:window_rec);
{ Useful procedure not provided in the CRT unit, clear from current
cursor position to the end of the current window. Cursor is left
(actually returned to) at the current position.
The window_rec passed as a parameter describes the currently active
window. }
var
x, y, i : byte;
begin
clreol; { clear tail of current line }
y := wherey;
x := wherex;
for i := y+1 to wr.ysize+1 do { for next line to maxline }
begin
gotoxy(1,i); { go to start of line }
clreol; { and clear it }
end;
gotoxy(x,y); { restore cursor }
end;

procedure open_window(wr:window_rec);
{ Open (or reopen) a window. If the underlying screen needs to be restored
when the window is 'closed' wr.save should be set TRUE. If the window
opened needs to be cleared, set wr.clear TRUE and if you want a border
around the window, set wr.border TRUE. No error checking is performed so
if any of the x or y values would overflow the physical screen results
will be unpredictable. }
var
i, j : word;
x1,x2,y1,y2 : byte;
begin
textcolor (wr.fgcolor);
textbackground(wr.bkgcolor);
if wr.save then savescr;
x1 := wr.ulx;
x2 := wr.ulx+wr.xsize;
y1 := wr.uly;
y2 := wr.uly+wr.ysize;
if wr.border then begin
window(1,1,80,25);
gotoxy(x1-1,y1-1);
write(ulc);
for i := x1 to x2 do write(hbar);
write (urc);
for i := y1 to y2 do
begin
gotoxy(x2+1,i);
write(vbar);
end;
for i := y1 to y2 do
begin
gotoxy(x1-1,i);
write(vbar);
end;
gotoxy(x1-1,y2+1);
write(llc);
for i := x1 to x2 do write(hbar);
write(lrc);
end;
window(x1,y1,x2,y2);
if wr.clear then clrscr;
end;


procedure error(line, column : byte; time:word; s:string;wr:window_rec);
{ Display an error message at physical column, line (flashing, reverse video)
then wait for either TIME seconds to expire, or for a keystroke. The screen
area overlayed by the error message is saved on entry, restored on exit.
This routine opens a one line window for the error message, then restores
the window status passed in wr. Only minimal error checking performed. }
var
x,y : byte;
ch : char;
tt : longint;
temp : array[0..159] of byte;
begin
x := wherex; { save cursor position for caller }
y := wherey;
if length(s)+column+1 > 80 then exit; { restrict to one line }
dec(line); { screen memory addresses are zero based }
dec(column);
tt := 0; { local timer }
move(mem[scrnseg:line*160+column*2], temp, (length(s)*2)+4);
{ save error area's data }
window(column+1,line+1,column+1+length(s)+1,line+1);
textbackground(wr.fgcolor);
clrscr;
textcolor(wr.bkgcolor+blink); { blinking reverse video }
write(s);
repeat
delay(250); { each quarter second }
inc(tt); { bump local timer }
until (tt div 4 > time) or keypressed; { check for time up, or keystroke }
if keypressed then ch := readkey;
move(temp, mem[scrnseg:line*160+column*2], (length(s)*2)+4);
{ restore physical screen data }
window(wr.ulx,wr.uly,wr.ulx+wr.xsize,wr.uly+wr.ysize);
textcolor(wr.fgcolor);
textbackground(wr.bkgcolor);
{ restore caller's window }
gotoxy(x,y);
end;

begin
mgr_ok := setupscreen;
end.





{ Listing 2 }

program test_mgr;
uses
crt, scrnmgr;
var
w1, w2 : window_rec;
a : word;
ch : char;
begin
with w1 do begin
ulx := 5; uly := 5;
xsize := 25; ysize := 7;
fgcolor := green; bkgcolor := blue;
border := true; clear := true; save := true;
end;
with w2 do begin
ulx := 3; uly := 3;
xsize := 75; ysize := 20;
fgcolor := yellow; bkgcolor := cyan;
border := true; clear := true; save := false;
end;
if mgr_ok then begin
open_window(w2);
w2.clear := false; w2.border := false;
for a := 1 to 35 do
write('':a,'This is a test of window 2');

ch := readkey;
open_window(w1);
for a := 1 to 10 do
writeln('':a,'This is window 1.');
ch := readkey;
error(13,12,300,'This is an error message.',w1);
ch := readkey;
restorescr;
open_window(w2);
ch := readkey;
gotoxy(17,4);
clreos(w2);
ch := readkey;
end;
end.