Power-Programmierung/CD1.mdf/pascal/library/dos/grafik/wct_unit/xcrt.pas

Pascal/Delphi Source File | 1992-05-24 | 23.4 KB | 834 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 is 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,strings;

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 (and a little faster) 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
  screenbuffer=array [1..50] of array [1..80] of record
    ch: char;
    attr: byte;
    end;
  screen=^screenbuffer;
  { This is a maximum size for a screen - 80 columns * 50 rows = 4000.
    The maximum space required would then be 8000 bytes. }
  blockbuffer=array[0..3999] of word;
  blockbufferptr=^blockbuffer;
  block=record
    rows,cols: byte;
    sp: blockbufferptr;
    end;
  getoneofstring=string[120];
  writexystring=string[80];

var
  originalscreen: screen;
  actualscreen: screen;
  activescreen: screen;
  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 }
  videoseg: word;          { Location of screen in memory }
  explodesteps: byte;      { Number of steps to explode a window }

procedure beep(hz,dur: word);
procedure disablespeaker;
procedure enablespeaker;
procedure bordercolor(color:byte);
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;
procedure flushkeyboard;
function yesorno:char;
function getoneof(s:getoneofstring):char;
function getcursor:word;
procedure setcursor(curs:word);
procedure makescreen(var s: screen);
procedure killscreen(var s: screen);
procedure setactivescreen(var s: screen);
procedure setvisualscreen(var s: screen);
procedure writewindow(var f: file; var w: block);
procedure readwindow(var f: file; var w: block);
procedure savewindow(x1,y1,x2,y2: word; var w: block);
procedure killwindow(var w:block);
procedure drawstrip(w:block; x1,y1:byte; row:byte; x2,x3:byte);
procedure recallwindow(x1,y1:word; var w: block);
procedure explodewindow(x1,y1: byte; w:block);
procedure crunchwindow(x1,y1:byte; 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]=('      ',
                                    #218+#196+#191+#179+#217+#192,
                                    #201+#205+#187+#186+#188+#200,
                                    #213+#205+#184+#179+#190+#212,
                                    #214+#196+#183+#186+#189+#211);

var
  regs: registers;
  visualscreenptr: ^screen;

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

procedure disablespeaker;
{ This procedure turns off the 0 & 1 bits of port[$61], which controls
  the speaker }
begin
  port[$61]:=port[$61] and $FC;
end;

procedure enablespeaker;
{ This procedure turns the 0 & 1 bits of port[$61] back on }
begin
  port[$61]:=port[$61] or $03;
end;

procedure bordercolor(color:byte);
{ Colors the border around the (1,1) (80,25) corners Color }
begin
  fillchar(regs,sizeof(regs),0);
  regs.ax:=$0B00;
  regs.bh:=$00;
  regs.bl:=12;
  intr($10,regs);
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:=activescreen^[y,x].ch;
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:=activescreen^[y,x].attr;
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 begin
    activescreen^[y,x].ch:=c;
    activescreen^[y,x].attr:=textattr;
    end
  else activescreen^[y,x].ch:=c;
end;

procedure putattr(x,y,attr: byte);
{ Directly change the color attributes of char at absolute screen (x,y) }
begin
  activescreen^[y,x].attr:=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,#196)
    else for i:=startat to endat do putch(i,c,#205)
    end
  else
    if attr div 2=0 then for i:=startat to endat do putch(c,i,#179)
    else for i:=startat to endat do putch(c,i,#186)
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,#219);
  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;
  w: word;
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)/(explodesteps*2+1);
  dc:=(y2-y1+1)/(explodesteps*2+1);
  mr:=(x1+x2+1)/2;
  mc:=(y1+y2+1)/2;
  for i:=1 to explodesteps 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 flushkeyboard;
{ flushes the keyboard type-ahead buffer }
begin
  fillchar(regs,sizeof(regs),0);
  regs.ax:=$0C00;
  intr($21,regs)
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 makescreen(var s: screen);
begin
  if maxavail<80*50*2 then halt(1);
  getmem(s,80*50*2);
end;

procedure killscreen(var s: screen);
begin
  if s=activescreen then exit;
  if visualscreenptr=@s then exit;
  freemem(s,80*50*2);
end;

procedure setactivescreen(var s: screen);
begin
  activescreen:=s;
end;

procedure setvisualscreen(var s: screen);
var
  temp: pointer;
  buf: blockbufferptr;
  swapped: word;
  section: word;
begin
  { swap actual screen contents and s^ }
  swapped:=0;
  repeat
    if maxavail>4000-swapped then section:=4000
    else section:=maxavail;
    getmem(buf,section*2);
    move(actualscreen^[(swapped div 80)+1,(swapped mod 80)+1],buf^[swapped],section*2);
    move(s^[(swapped div 80)+1,(swapped mod 80)+1],actualscreen^[(swapped div 80)+1,(swapped mod 80)+1],section*2);
    move(buf^[swapped],s^[(swapped div 80)+1,(swapped mod 80)+1],section*2);
    freemem(buf,section*2);
    swapped:=swapped+section;
  until swapped>=4000;
  { swap the pointers }
  temp:=s;
  s:=visualscreenptr^;
  visualscreenptr^:=temp;
  { visualscreenptr contains the address of the old visual screen pointer }
  visualscreenptr:=@s;
end;

procedure writewindow(var f: file; var w: block);
{ writes window to a file
  1/16/92 - Improved speed by using BLOCKWRITE
  4/22/92 - changed parameter to a file that must be pre-reset }
var
  i,j: byte;
begin
  with w do begin
    blockwrite(f,rows,1);
    blockwrite(f,cols,1);
    blockwrite(f,sp^,rows*cols*2);
    end;
end;

procedure readwindow(var f: file; var w: block);
{ 1/16/92 - Improved speed by using BLOCKREAD
  4/22/92 - changed parameter to a file that must be pre-reset }
begin
  with w do begin
    blockread(f,rows,1);
    blockread(f,cols,1);
    getmem(sp,rows*cols*2);
    blockread(f,sp^,rows*cols*2);
    end;
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).  1/15/92 - Doubled speed of
  SaveWindow and RecallWindow by utilizing MOVE.  }
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:=y2-y1+1;
    cols:=x2-x1+1;
    size:=rows*cols*2;    { bytes required to store screen }
    getmem(sp,size);      { allocate sufficient space }
    for j:=y1 to y2 do
      move(activescreen^[j,x1],sp^[(j-y1)*cols],cols*2);
    end
end;

procedure killwindow(var w:block);
{ Free space taken up by screen block }
begin
  freemem(w.sp,w.rows*w.cols*2);
  w.rows:=0;
  w.cols:=0
end;

procedure drawstrip(w:block; x1,y1:byte; row:byte; x2,x3:byte);
{ Draws one strip of a block
  w = block to be drawn
  x1,y1 = upper-left corner of block (absolute)
  row = (absolute row to be drawn)
  x2,x3 = x limits of strip to be drawn }
begin
  if x3<x2 then exit;
  with w do
    move(sp^[(row-y1)*cols+(x2-x1)],
         memw[videoseg:(row-1)*160+(x2-1)*2],
         (x3-x2+1)*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 j:=y1 to y1+rows-1 do
      drawstrip(w,x1,y1,j,x1,x1+cols-1);
end;

procedure explodewindow(x1,y1: byte; w:block);
{ Explodes a window with (x1,y1) as upper-left corner. }
var
  mx,my: real;
  dx,dy: real;
  x2,x3: byte;
  i,j,k: byte;
begin
  with w do begin
    mx:=x1+cols/2;
    my:=y1+rows/2;
    dx:=cols/(explodesteps*2+1);
    dy:=rows/(explodesteps*2+1);
    for k:=1 to explodesteps do
      for j:=trunc(my-k*dy) to trunc(my+k*dy) do begin
        x2:=trunc(mx-k*dx);
        x3:=trunc(mx+k*dx);
        drawstrip(w,x1,y1,j,x2,x3);
        end;
    recallwindow(x1,y1,w)
    end;
end;

procedure crunchwindow(x1,y1:byte; w:block);
{ Draw window from outside-in, opposite to explode window }
var
  dx,dy: real;
  x2,y2: byte;  { upper-left of inner box }
  x3,y3: byte;  { lower-right of inner box }
  j,k: byte;
begin
  with w do begin
    dx:=cols/(explodesteps*2+1);
    dy:=rows/(explodesteps*2+1);
    for k:=1 to explodesteps do begin
      x2:=round(x1+k*dx);
      y2:=round(y1+k*dy);
      x3:=round(x1+cols-1-k*dx);
      y3:=round(y1+rows-1-k*dy);
      for j:=y1 to y1+rows-1 do
        if (j<=y2) or (j>=y3) then drawstrip(w,x1,y1,j,x1,x1+cols-1)
        else begin
          drawstrip(w,x1,y1,j,x1,x2);
          drawstrip(w,x1,y1,j,x3,x1+cols-1)
          end;
      end;
    recallwindow(x1,y1,w);
    end;
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;
 { initialize misc. stuff }
  explodesteps:=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;
  actualscreen:=ptr(videoseg,0);
  originalscreen:=ptr(videoseg,0);
  visualscreenptr:=@originalscreen;
  activescreen:=actualscreen;
  crtrows:=getfont;
end;

begin
  xcrtinit;
end.

This is a list of the CRT procedures and functions.  I would like to replace
them all with my own routines eventually.

AssignCrt         ClrEol √          ClrScr √          Delay
DelLine           GotoXY            HighVideo         InsLine
KeyPressed        LowVideo          NormVideo         NoSound
ReadKey √         Sound             TextBackground √  TextColor √
TextMode √        WhereX            WhereY            Window

function xreadkey:char;
var
  r: registers;
begin
  with r do begin
    ah:=8;
    msdos(r);
    xreadkey:=chr(r.al);
  end;
end;

procedure xclrscr;
var
  t: boolean;
begin
  t:=preserveattr;
  preserveattr:=false;
  fillblock(1,1,crtcols,crtrows,' ');
  preserveattr:=t
end;

procedure xclreol;
begin
  writexy(wherex,wherey,rep(' ',crtcols+1-wherex))
end;

procedure xtextbackground(c:byte);
begin
  textattr:=(textattr and $8F) or (c*16)
end;

procedure xtextcolor(c:byte);
begin
  textattr:=(textattr and $F0) or c
end;