uses dos,crt,tpfast;

const
    swidth                = 80;
    sheight               = 25;
    LEFT                 = 330;
    RIGHT   = 332;
    UP      = 327;
    DOWN    = 335;
    ESC     = 27;



type
    wholescreen           = array [1..(swidth*sheight)*2] of byte;


var loop                  :byte;
    dtime                 :word;
    ch                    :word;
    c                     :char;
    b                     :byte;


{ -------------------------------------------------------------------------- }
procedure showproc(msg :string);

begin
  fillscreen(' ',1,24,80,24,lightcyan);
  dspat(msg,1,24,lightcyan);
end;

{ -------------------------------------------------------------------------- }
procedure statusmsg(msg :string);

var ch      :char;
begin
  dspc(msg,25,yellow+_blue);
  ch := readkey;
  fillscreen(' ',1,25,80,25,yellow+_blue);
end;


{ -------------------------------------------------------------------------- }
function get_key :word;
{ returns a key press and checks for extended key presses returning a }
{ unique word. }
var ch         :char;

begin
  ch := readkey;
  if ch = #00 then
       get_key := ord(readkey)+255
   else
       get_key := ord(ch);
end;

{ -------------------------------------------------------------------------- }
procedure boxdemo;

begin
showproc('procedure drawbox(char_x ,char_y  :char;x,y,xx,yy,colour :byte);');
for loop := 1 to 10 do
  begin
    delay(dtime);
    drawbox('s','s',loop,loop,80-(loop*2),25-(loop*2),loop);
  end;
for loop := 1 to 10 do
  begin
    delay(dtime);
    drawbox('d','d',loop,loop,80-(loop*2),25-(loop*2),loop);
  end;
for loop := 1 to 10 do
  begin
    delay(dtime);
    drawbox('s','d',loop,loop,80-(loop*2),25-(loop*2),loop);
  end;
for loop := 1 to 10 do
  begin
    delay(dtime);
    drawbox('d','s',loop,loop,80-(loop*2),25-(loop*2),loop);
  end;
statusmsg('Hit any key to continue......');
end;
{ -------------------------------------------------------------------------- }
procedure scrolldemo;

begin
clrscr;
showproc('scrolly,scrollx(where :char; x,y,xx,yy,cols,colour :byte);');

dspat('Turbo Pascal has a primative scrolling',5,5,white+_blue);
dspat('mechanism. These procedure operate  on',5,6,white+_blue);
dspat('the whole  screen or in  a window. The',5,7,white+_blue);
dspat('scrollx procedure is  pretty good  for',5,8,white+_blue);
dspat('things  such as  animation and  so on.',5,9,white+_blue);
dspat('These procedures not  only scroll  the',5,10,white+_blue);
dspat('screen but leave the  remaining  lines',5,11,white+_blue);
dspat('in  a   user  specified  attribute ...',5,9,white+_blue);

statusmsg('Press LEFT ,RIGHT, UP, DOWN keys to scroll');
repeat
  ch := get_key;
  case (ch) of
     LEFT   : scrollx('l',5,5,38,7,1,white+_blue);
     RIGHT  : scrollx('r',5,5,38,7,1,white+_blue);
     UP     : scrolly('u',5,5,38,7,1,white+_blue);
     DOWN   : scrolly('d',5,5,38,7,1,white+_blue);
  end;
until ch = ESC;
end;

{ -------------------------------------------------------------------------- }
procedure fillscreendemo;

var loop          :byte;

begin
clrscr;
showproc('procedure fillscreen(ch :char; x,y,xx,yy,colour :byte);');
fillscreen(chr(176),1,1,80,5,yellow);
fillscreen(chr(177),1,7,80,5,yellow);
fillscreen(chr(178),1,13,80,5,yellow);
statusmsg('And now to fill the entire screen from chars A-Z');
for loop := 65 to 90 do
  fillscreen(chr(loop),1,1,80,25,loop);
end;

{ -------------------------------------------------------------------------- }
procedure savescreendemo;


var      screenptr         :wholescreen;

begin
 dspat('This screen will be saved with the savescreen',5,5,white+_blue);
 dspat('procedure and  then  restored again  with the',5,6,white+_blue);
 dspat('restorescreen  procedure.  Other   procedures',5,7,white+_blue);
 dspat('include the following.',5,8,white+_blue);
 dspat('screenleft  - moves a screen left.',5,9,white+_blue);
 dspat('screenright - moves a screen right',5,10,white+_blue);
 dspat('screenup    - moves a screen up',5,11,white+_blue);
 dspat('screendown  - moves a screen down',5,12,white+_blue);

savescreen(@screenptr,1,1,80,25);
statusmsg('The screen has been saved , press any key to restore');
clrscr;
delay(500);
restorescreen(@screenptr,1,1,80,25);

statusmsg('Now I will use copyclear to save the screen ...');
copyclear(@screenptr,1,1,80,25,white);
statusmsg('Press any key to restore the screen');
restorescreen(@screenptr,1,1,80,25);
statusmsg('Press any key to continue');
end;

{ -------------------------------------------------------------------------- }
procedure movescreendemo(dtime :word);

var     x,y             :byte;
        loop            :byte;
        screenptr       :wholescreen;


begin
 clrscr;
 x := 15;
 y := 8;
 dspat('These are some move screen procedures. ',x,y,white+_blue);
 dspat('screenleft  - moves a screen left.     ',x,y+1,white+_blue);
 dspat('screenright - moves a screen right     ',x,y+2,white+_blue);
 dspat('screenup    - moves a screen up        ',x,y+3,white+_blue);
 dspat('screendown  - moves a screen down      ',x,y+4,white+_blue);

savescreen(@screenptr,1,1,80,25);

for loop := 1 to 5 do
  begin
    screenleft(@screenptr,x,y,39,5);
    delay(dtime);
  end;
for loop := 1 to 5 do
  begin
    screenup(@screenptr,x,y,39,5);
    delay(dtime);
  end;
for loop := 1 to 20 do
  begin
    screenright(@screenptr,x,y,39,5);
    delay(dtime);
  end;
for loop := 1 to 15 do
  begin
    screendown(@screenptr,x,y,39,5);
    delay(dtime);
  end;
end;

{ -------------------------------------------------------------------------- }

begin
clrscr;
dtime := 100;
boxdemo;
scrolldemo;
fillscreendemo;
savescreendemo;
movescreendemo(50);
statusmsg(' And now the same with no delays.....');
movescreendemo(0);
ch := get_key;
end.