ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/WCTUNITS.ZIP/XCRT.PAS

Pascal/Delphi Source File | 1991-07-30 | 17.1 KB | 589 lines

unit xcrt;

{ Written by William C. Thompson ([e-mail]) - 1991
  Parts of this unit were taken from HTScreen, written by
  Harold Thunem. }

{ If anyone has an idea for a procedure, please E-mail and I
  will consider including it in my unit.  It should be something
  that you do often. }

(* Features to be added:
  Another unit containing definitions for different musical tones *)

{ Designer's Notes:
  1. This unit was written was with the goal of making tedious crt
     routines much more bearable by modularizing the entire process.
     Another goal is to make the routines very fast by directly
     affecting memory.  Consequently, much of the error checking has
     been left out.  The user is responsible for error checking his
     own code.  In many cases this proves to give the user more
     control, and there is little or no overhead if the code was
     written with some care.  For example, many times a rectangle
     is defined by (x1,y1) & (x2,y2) which represent the upper-left
     and lower-right corners, respectively.  If x1>x2 or y1>y2 the
     call is often ignored.
  2. When setting foreground colors, you can set the blink constant
     by adding 128 (pre-defined as 'blink') to the foreground color.
  3. As yet, this unit is only designed to handle screens with
     80 columns.  Including checking for 40 columns would slow
     down the procedures which are intended to be very fast.
     A program using 40 columns could easily borrow the ideas
     used in this unit.  I have confirmed that they do work for
     43/50 rows.  Many don't work for 40 columns.
  4. All window-like procedures are in absolute coordinates.  Once
     again, it up to the user to maintain relative coordinates
     somehow (it is not very difficult) because that would slow down
     the routines for other uses.
  5. My apologies for my somewhat abnormal style of indentation, but
     at least it is consistent (unlike some other code I have seen).
     You may also notice that I avoid white spaces and capitalization
     with a passion.  It seems very silly to worry about how many
     spaces I have put between variables, so I don't put any unless
     absolutely necessary.  I do try to keep my commenting neat, when
     convenient. }

interface

uses crt,dos,keydef;

const
  blackbg=$00;
  bluebg=$10;
  greenbg=$20;
  cyanbg=$30;
  redbg=$40;
  magentabg=$50;
  brownbg=$60;
  lightgraybg=$70;
 { Setting the text color and background color at the same time can
   be very tedious.  You have to say TextColor(X) and TextBackGround(Y),
   which is much too much typing.  You can also be clever and set
   TextAttr:=Y*16+X, which is a pain.  This can be made simpler by
   setting TextAttr:=YBG+X, which sets the background color at the
   same with a minimum of typing.  It also lets you avoid trying to
   set background colors to 8-15, something that I have tried often.
   More importantly, it makes it clearer to see what is happening.

   For example, instead of

   TextColor(White); TextBackGround(Cyan) or TextAttr:=Cyan*16+White,

   much simpler would be

   TextAttr:=CyanBG+White.

    If you wish to set only the background or foreground color (but
    not both), you can still use TextColor and TextBackGround. }

  { Text fonts, 25 or 43/50 rows }
  ega43font=1;
  normalfont=2;

 { border constants }
  noborder=0;
  singleborder=1;
  doubleborder=2;
  dtopsside=3;
  stopdside=4;

 { textline constants }
  thinhoriz=0;
  thinvert=1;
  thickhoriz=2;
  thickvert=3;

type
  screenpt=^screen;
  screen=array[0..3999] of word;
  { This is a maximum size for a screen - 80 columns * 50 rows = 4000.
    The maximum space required would then be 8000 bytes. }
  block=record
    rows,cols: word;
    sp: screenpt
    end;
  getoneofstring=string[120];
  writexystring=string[80];

var
  badkeybeep: boolean;     { beep when a bad is pressed? }
  badkeyhz: word;          { sound to emit for bad key }
  badkeydur: word;         { duration of bad key beep }
  goodkeybeep: boolean;    { beep when a good key is pressed }
  goodkeyhz: word;         { sound to emit for good key }
  goodkeydur: word;        { duration of good key beep }
  cursorinitial, cursoroff, cursorunderline,
    cursorhalfblock, cursorblock: word;    { cursor settings }
  preserveattr: boolean;
  { If preserveattr=true, putch will preserve the attribute settings
    for a location on the screen.  If preserveattr=false (default),
    it will change the color attributes to the setting held in
    textattr. }
  crtrows,                 { Number of rows }
  crtcols,                 { Number of columns }
  videomode:byte;          { Video-mode }

procedure beep(hz,dur: word);
function getch(x,y: byte):char;
function getattr(x,y: byte):byte;
procedure putch(x,y: byte; c: char);
procedure putattr(x,y:byte; attr:byte);
function shadowattr(attr:byte):byte;
procedure writexy(x,y: byte; s: writexystring);
procedure rightjust(x,y: byte; s: writexystring);
procedure centerjust(x,y:byte; s:writexystring);
procedure textbox(x1,y1,x2,y2: word; border:byte);
procedure textline(startat,endat,c:word; attr:byte);
procedure colorblock(x1,y1,x2,y2: word; c:byte);
procedure fillblock(x1,y1,x2,y2:word; ch:char);
procedure shadowblock(x1,y1,x2,y2:word);
procedure attrblock(x1,y1,x2,y2:word; attr:byte);
procedure scrollblockup(x1,y1,x2,y2,wakeattr:byte);
procedure scrollblockdown(x1,y1,x2,y2,wakeattr:byte);
procedure explodeblock(x1,y1,x2,y2:byte);
function readallkeys:char;
function yesorno:char;
function getoneof(s:getoneofstring):char;
function getcursor:word;
procedure setcursor(curs:word);
procedure savewindow(x1,y1,x2,y2: word; var w: block);
procedure killwindow(var w:block);
procedure recallwindow(x1,y1:word; var w: block);
function getfont:byte;
procedure setfont(font:byte);
function getvideomode:byte;
procedure setvideomode(mode:byte);
procedure xcrtinit;

implementation

const
  borders:array[0..4] of string[6]=('      ',
                                    '┌─┐│┘└',
                                    '╔═╗║╝╚',
                                    '╒═╕│╛╘',
                                    '╓─╖║╜╙');

var
  regs: registers;
  videoseg: word;        { Video segment address }

procedure beep(hz,dur: word);
begin
  sound(hz);
  delay(dur);
  nosound
end;

function getch(x,y: byte):char;
{ returns character at absolute position (x,y) through memory
  The error checking has been removed to speed up function }
begin
  getch:=char(mem[videoseg:(160*y+2*x-162)]);    { 2*80*(y-1)+2*(x-1) }
end;

function getattr(x,y: byte):byte;
{ returns color attribute at absolute position (x,y) through memory
  The error checking has been removed to speed up function }
begin
  getattr:=mem[videoseg:(160*y+2*x-161)];    { 2*80*(y-1)+2*(x-1)+1 }
end;

procedure putch(x,y: byte; c: char);
{ QUICKLY writes c to absolute position (x,y) through memory
  This is at least 10 times faster than a gotoxy(x,y), write(c)
  Another bonus is that the cursor doesn't move.
  The error checking has been removed  }
begin
  if not preserveattr then
    memw[videoseg:(160*y+2*x-162)]:=textattr shl 8+ord(c)
  else mem[videoseg:(160*y+2*x-162)]:=ord(c)
end;

procedure putattr(x,y,attr: byte);
{ Directly change the color attributes of char at absolute screen (x,y) }
begin
  mem[videoseg:(160*y+2*x-161)]:=attr
end;

function shadowattr(attr:byte):byte;
{ Returns an appropriate shadow attribute.  First it masks out the
  upper four bits (background of shadow is always black) as well as
  the 3rd bit (a shadow should be a dark color).  Unfortunately,
  if the text color is black, you can't see it, so there is a
  special case for that (sets it to lightgray). }
var
  temp: byte;
begin
  temp:=attr and $07;
  if temp=black then shadowattr:=lightgray
  else shadowattr:=temp
end;

procedure writexy(x,y: byte; s: writexystring);
{ Writes string s at absolute (x,y) - left justified }
var
  i: byte;
begin
  for i:=1 to length(s) do putch(x+i-1,y,s[i])
end;

procedure rightjust(x,y: byte; s: writexystring);
{ Right justifies string s at absolute (x,y) }
begin
  writexy(x-length(s)+1,y,s)
end;

procedure centerjust(x,y:byte; s:writexystring);
{ Centers string s about x at y }
begin
  writexy(x-length(s) div 2,y,s)
end;

procedure textbox(x1,y1,x2,y2: word; border:byte);
{ draws a text box defined by the two points }
var
  i: integer;
  ch: char;
  s: string[6];
begin
  if not border in [1..4] then exit;
  s:=borders[border];
  { handle special cases first, x1=x2 or y1=y2 }
  if x1=x2 then   { straight line down }
    for i:=y1 to y2 do putch(x1,i,s[4])
  else if y1=y2 then  { straight line across }
    for i:=x1 to x2 do putch(i,y1,s[2])
  else if (x1<x2) and (y1<y2) then begin
    { draw corners }
    putch(x1,y1,s[1]);
    putch(x1,y2,s[6]);
    putch(x2,y2,s[5]);
    putch(x2,y1,s[3]);
    { draw lines }
    for i:=y1+1 to y2-1 do putch(x1,i,s[4]);
    for i:=y1+1 to y2-1 do putch(x2,i,s[4]);
    for i:=x1+1 to x2-1 do begin
      putch(i,y1,s[2]);
      putch(i,y2,s[2]);
      end
    end
end;

procedure textline(startat,endat,c:word; attr:byte);
{ The first two parameters are the starting and ending values
  of the range of the line, vertical or horizontal.  The third
  is the constant value.  i.e. horiz => (x1,x2,y), vert => (y1,y2,x) }
var
  i: integer;
begin
  if attr mod 2=0 then begin
    gotoxy(startat,c);
    if attr div 2=0 then for i:=startat to endat do putch(i,c,'─')
    else for i:=startat to endat do putch(i,c,'═')
    end
  else
    if attr div 2=0 then for i:=startat to endat do putch(c,i,'│')
    else for i:=startat to endat do putch(c,i,'║')
end;

procedure colorblock(x1,y1,x2,y2:word; c:byte);
{ Fills block with █ in the specified color - preserves color settings.
  Can conflict with shadowing - ShadowBlock changes the background
  color of the shadowed region to black and foreground colors to
  the approriate shadowed color.  Therefore, if you shadow a region
  containing █'s, it will not make them black.  Make sense?  If you
  intend to use shadowing, you are better off making regions with
  background colors and using FillBlock.  In addition, if text is to
  be put in the area, the text must have an appropriate background
  color.  ColorBlock should basically only be used for cosmetic
  purposes (such as filling in the sides of the screen), as it
  conflicts with so many other routines. }
var
  i,j:byte;
  sc: byte;
begin
  sc:=textattr;
  textcolor(c);
  for i:=x1 to x2 do
    for j:=y1 to y2 do putch(i,j,'█');
  textattr:=sc
end;

procedure fillblock(x1,y1,x2,y2:word; ch:char);
{ Fills a block with the specified character using the current
  color settings.  If you want to empty a region, set the colors
  by setting (as an example) TextAttr=CyanBG+White (cyan background
  with a white foreground) and the fill the block with ' '. }
var
  i,j:byte;
begin
  for i:=x1 to x2 do
    for j:=y1 to y2 do putch(i,j,ch)
end;

procedure shadowblock(x1,y1,x2,y2:word);
{ Shadows a block using the appropriate shadowing
  for each character's color attribute }
var
  i,j:byte;
begin
  for i:=x1 to x2 do
    for j:=y1 to y2 do putattr(i,j,shadowattr(getattr(i,j)))
end;

procedure attrblock(x1,y1,x2,y2:word; attr:byte);
{ Changes the foreground and background colors within the
  specified rectangle.  This is different from shadowblock,
  which uses the appropriate shadowing for a color attribute. }
var
  i,j: byte;
begin
  for i:=x1 to x2 do
    for j:=y1 to y2 do putattr(i,j,attr);
end;

procedure scrollblockup(x1,y1,x2,y2,wakeattr:byte);
{ Scrolls a block up and leaves the wakeattr color in the empty row }
begin
  fillchar(regs,sizeof(regs),0);
  regs.ah:=$06;
  regs.al:=$01;
  regs.bh:=wakeattr;
  regs.ch:=y1-1;
  regs.cl:=x1-1;
  regs.dh:=y2-1;
  regs.dl:=x2-1;
  intr($10,regs);
end;

procedure scrollblockdown(x1,y1,x2,y2,wakeattr:byte);
{ Scrolls a block down and leaves the wakeattr color in the empty row }
begin
  fillchar(regs,sizeof(regs),0);
  regs.ah:=$07;
  regs.al:=$01;
  regs.bh:=wakeattr;
  regs.ch:=y1-1;
  regs.cl:=x1-1;
  regs.dh:=y2-1;
  regs.dl:=x2-1;
  intr($10,regs);
end;

procedure explodeblock(x1,y1,x2,y2:byte);
{ explodes a block }
var
  i,r1,r2,c1,c2: byte;
  mr,mc,dr,dc: real;
begin
  dr:=(x2-x1+1)/11;
  dc:=(y2-y1+1)/11;
  mr:=(x1+x2+1)/2;
  mc:=(y1+y2+1)/2;
  for i:=1 to 5 do begin
    r1:=trunc(mr-i*dr);
    r2:=trunc(mr+i*dr);
    c1:=trunc(mc-i*dc);
    c2:=trunc(mc+i*dc);
    fillblock(r1,c1,r2,c2,' ');
    end;
  fillblock(x1,y1,x2,y2,' ');
end;

function readallkeys:char;
{ This function correctly reads in a keypress and returns the
  correct value for "other" keys.  See the KEYDEF unit for what
  each special key returns.  Note: the function doesn't return
  an actual character for special keys (F1-F10,etc.) - it is only
  a character to represent the special key that was pressed. }
var
  ch: char;
begin
  ch:=readkey;
  if ch=#0 then readallkeys:=transformedkey(readkey)
  else readallkeys:=ch
end;

procedure badkeysound;
begin
  beep(badkeyhz,badkeydur);
end;

procedure goodkeysound;
begin
  beep(goodkeyhz,goodkeydur)
end;

function yesorno:char;
{ waits for the user to press 'y','Y','n','N' }
var
  ch: char;
begin
  repeat
    ch:=upcase(readallkeys);
    if not (ch in ['Y','N']) and badkeybeep then badkeysound
  until ch in ['Y','N'];
  yesorno:=ch;
  if goodkeybeep then goodkeysound
end;

function getoneof(s:getoneofstring):char;
{ waits for the user to input a character contained in cs }
var
  ch: char;
begin
  repeat
    ch:=readallkeys;
    if badkeybeep and (pos(ch,s)<=0) then badkeysound
  until pos(ch,s)>0;
  getoneof:=ch;
  if goodkeybeep then goodkeysound;
end;

function getcursor:word;
{ returns cursor size }
begin
  getcursor:=(mem[$0040:$0060] shl 4)+mem[$0040:$0061];
end;

procedure setcursor(curs:word);
{ sets cursor size }
begin
  fillchar(regs,sizeof(regs),0);
  regs.ah:=$01;
  regs.ch:=curs mod 16;
  regs.cl:=curs div 16;
  intr($10,regs);
end;

procedure savewindow(x1,y1,x2,y2: word; var w: block);
{ This procedure saves a screen block.  It is not intended to
  open up a window, but can be used to store what is underneath
  a window.  (absolute coordinates) }
var
  i,j: word;
  size: word;
begin
  with w do begin
    rows:=0;
    cols:=0;
    if (x2<x1) and (y2<y1) then exit;    { invalid window }
    rows:=x2-x1+1;
    cols:=y2-y1+1;
    size:=rows*cols*2;    { bytes required to store screen }
    getmem(sp,size);      { allocate sufficient space }
    for i:=0 to rows-1 do
      for j:=0 to cols-1 do
        sp^[j*rows+i]:=memw[videoseg:(160*(j+y1)+2*(i+x1)-162)];
    end
end;

procedure killwindow(var w:block);
{ Free space taken up by screen block (absolute coordinates) }
begin
  with w do freemem(sp,rows*cols*2)
end;

procedure recallwindow(x1,y1:word; var w:block);
{ redraw window at (x1,y1) (absolute coordinates) }
var
  i,j: word;
begin
  with w do
    for i:=0 to rows-1 do
      for j:=0 to cols-1 do
        memw[videoseg:(160*(j+y1)+2*(i+x1)-162)]:=sp^[j*rows+i]
end;

function getfont:byte;
{ gets the number of rows on the screen }
begin
  fillchar(regs,sizeof(regs),0);
  regs.ah:=$11;
  regs.al:=$30;
  regs.bh:=$02;
  intr($10,regs);
  getfont:=regs.dl+1;
end;

procedure setfont(font:byte);
{ sets the number of rows on the screen:25 or 43/50 }
begin
  if font=normalfont then begin
    fillchar(regs,sizeof(regs),0);
    regs.ah:=$00;
    regs.al:=videomode;
    intr($10,regs);
    crtrows:=25;
    end
  else begin
    fillchar(regs,sizeof(regs),0);
    regs.ah:=$11;
    regs.al:=$12;
    regs.bh:=$00;
    intr($10,regs);
    crtrows:=getfont;
    end;
end;

function getvideomode:byte;
{ Returns the Video mode }
begin
  fillchar(regs,sizeof(regs),0);
  regs.ah:=$0F;
  intr($10,regs);
  getvideomode:=regs.al;
end;

procedure setvideomode(mode:byte);
{ sets the video mode }
begin
  if not mode in [$02,$03,$07] then exit;
  fillchar(regs,sizeof(regs),0);
  regs.ah:=$00;
  regs.al:=mode;
  intr($10,regs);
end;

procedure xcrtinit;
{ initializes some variables }
begin
 { initialize bad key settings }
  badkeybeep:=false;
  badkeyhz:=250;
  badkeydur:=50;
 { initialize good key settings }
  goodkeybeep:=false;
  goodkeyhz:=150;
  goodkeydur:=10;
  preserveattr:=false;
 { initialize videomode }
  videomode:=getvideomode;
  if not videomode in [$02,$03,$07] then halt;   { invalid video mode }
 { initialize cursor stuff }
  cursorinitial:=getcursor;
  crtcols:=80;
  case videomode of
    $02,$03:begin
      cursorunderline:=118;  { 6-7 }
      cursorhalfblock:=116;  { 4-7 }
      cursorblock:=113;      { 1-7 }
      cursoroff:=1;          { 0-1 }
      videoseg:=$B800;
      end;
    $07:begin
      cursorunderline:=203;  { 11-12 }
      cursorhalfblock:=198;   { 6-12 }
      cursorblock:=193;       { 1-12 }
      cursoroff:=1;           { 0- 1 }
      videoseg:=$B000;
      end;
    end;
  crtrows:=getfont;
end;

begin
  xcrtinit;
end.