home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPFAST40.ZIP / T_SCRN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-11-15  |  5.9 KB  |  226 lines
  1. uses dos,crt,tpfast;
  2.  
  3. const
  4.     swidth                = 80;
  5.     sheight               = 25;
  6.     LEFT                 = 330;
  7.     RIGHT   = 332;
  8.     UP      = 327;
  9.     DOWN    = 335;
  10.     ESC     = 27;
  11.  
  12.  
  13.  
  14. type
  15.     wholescreen           = array [1..(swidth*sheight)*2] of byte;
  16.  
  17.  
  18. var loop                  :byte;
  19.     dtime                 :word;
  20.     ch                    :word;
  21.     c                     :char;
  22.     b                     :byte;
  23.  
  24.  
  25. { -------------------------------------------------------------------------- }
  26. procedure showproc(msg :string);
  27.  
  28. begin
  29.   fillscreen(' ',1,24,80,24,lightcyan);
  30.   dspat(msg,1,24,lightcyan);
  31. end;
  32.  
  33. { -------------------------------------------------------------------------- }
  34. procedure statusmsg(msg :string);
  35.  
  36. var ch      :char;
  37. begin
  38.   dspc(msg,25,yellow+_blue);
  39.   ch := readkey;
  40.   fillscreen(' ',1,25,80,25,yellow+_blue);
  41. end;
  42.  
  43.  
  44. { -------------------------------------------------------------------------- }
  45. function get_key :word;
  46. { returns a key press and checks for extended key presses returning a }
  47. { unique word. }
  48. var ch         :char;
  49.  
  50. begin
  51.   ch := readkey;
  52.   if ch = #00 then
  53.        get_key := ord(readkey)+255
  54.    else
  55.        get_key := ord(ch);
  56. end;
  57.  
  58. { -------------------------------------------------------------------------- }
  59. procedure boxdemo;
  60.  
  61. begin
  62. showproc('procedure drawbox(char_x ,char_y  :char;x,y,xx,yy,colour :byte);');
  63. for loop := 1 to 10 do
  64.   begin
  65.     delay(dtime);
  66.     drawbox('s','s',loop,loop,80-(loop*2),25-(loop*2),loop);
  67.   end;
  68. for loop := 1 to 10 do
  69.   begin
  70.     delay(dtime);
  71.     drawbox('d','d',loop,loop,80-(loop*2),25-(loop*2),loop);
  72.   end;
  73. for loop := 1 to 10 do
  74.   begin
  75.     delay(dtime);
  76.     drawbox('s','d',loop,loop,80-(loop*2),25-(loop*2),loop);
  77.   end;
  78. for loop := 1 to 10 do
  79.   begin
  80.     delay(dtime);
  81.     drawbox('d','s',loop,loop,80-(loop*2),25-(loop*2),loop);
  82.   end;
  83. statusmsg('Hit any key to continue......');
  84. end;
  85. { -------------------------------------------------------------------------- }
  86. procedure scrolldemo;
  87.  
  88. begin
  89. clrscr;
  90. showproc('scrolly,scrollx(where :char; x,y,xx,yy,cols,colour :byte);');
  91.  
  92. dspat('Turbo Pascal has a primative scrolling',5,5,white+_blue);
  93. dspat('mechanism. These procedure operate  on',5,6,white+_blue);
  94. dspat('the whole  screen or in  a window. The',5,7,white+_blue);
  95. dspat('scrollx procedure is  pretty good  for',5,8,white+_blue);
  96. dspat('things  such as  animation and  so on.',5,9,white+_blue);
  97. dspat('These procedures not  only scroll  the',5,10,white+_blue);
  98. dspat('screen but leave the  remaining  lines',5,11,white+_blue);
  99. dspat('in  a   user  specified  attribute ...',5,9,white+_blue);
  100.  
  101. statusmsg('Press LEFT ,RIGHT, UP, DOWN keys to scroll');
  102. repeat
  103.   ch := get_key;
  104.   case (ch) of
  105.      LEFT   : scrollx('l',5,5,38,7,1,white+_blue);
  106.      RIGHT  : scrollx('r',5,5,38,7,1,white+_blue);
  107.      UP     : scrolly('u',5,5,38,7,1,white+_blue);
  108.      DOWN   : scrolly('d',5,5,38,7,1,white+_blue);
  109.   end;
  110. until ch = ESC;
  111. end;
  112.  
  113. { -------------------------------------------------------------------------- }
  114. procedure fillscreendemo;
  115.  
  116. var loop          :byte;
  117.  
  118. begin
  119. clrscr;
  120. showproc('procedure fillscreen(ch :char; x,y,xx,yy,colour :byte);');
  121. fillscreen(chr(176),1,1,80,5,yellow);
  122. fillscreen(chr(177),1,7,80,5,yellow);
  123. fillscreen(chr(178),1,13,80,5,yellow);
  124. statusmsg('And now to fill the entire screen from chars A-Z');
  125. for loop := 65 to 90 do
  126.   fillscreen(chr(loop),1,1,80,25,loop);
  127. end;
  128.  
  129. { -------------------------------------------------------------------------- }
  130. procedure savescreendemo;
  131.  
  132.  
  133. var      screenptr         :wholescreen;
  134.  
  135. begin
  136.  dspat('This screen will be saved with the savescreen',5,5,white+_blue);
  137.  dspat('procedure and  then  restored again  with the',5,6,white+_blue);
  138.  dspat('restorescreen  procedure.  Other   procedures',5,7,white+_blue);
  139.  dspat('include the following.',5,8,white+_blue);
  140.  dspat('screenleft  - moves a screen left.',5,9,white+_blue);
  141.  dspat('screenright - moves a screen right',5,10,white+_blue);
  142.  dspat('screenup    - moves a screen up',5,11,white+_blue);
  143.  dspat('screendown  - moves a screen down',5,12,white+_blue);
  144.  
  145. savescreen(@screenptr,1,1,80,25);
  146. statusmsg('The screen has been saved , press any key to restore');
  147. clrscr;
  148. delay(500);
  149. restorescreen(@screenptr,1,1,80,25);
  150.  
  151. statusmsg('Now I will use copyclear to save the screen ...');
  152. copyclear(@screenptr,1,1,80,25,white);
  153. statusmsg('Press any key to restore the screen');
  154. restorescreen(@screenptr,1,1,80,25);
  155. statusmsg('Press any key to continue');
  156. end;
  157.  
  158. { -------------------------------------------------------------------------- }
  159. procedure movescreendemo(dtime :word);
  160.  
  161. var     x,y             :byte;
  162.         loop            :byte;
  163.         screenptr       :^wholescreen;
  164.  
  165.  
  166. begin
  167.  new(screenptr);
  168.  clrscr;
  169.  x := 15;
  170.  y := 8;
  171.  dspat('These are some move screen procedures. ',x,y,white+_blue);
  172.  dspat('screenleft  - moves a screen left.     ',x,y+1,white+_blue);
  173.  dspat('screenright - moves a screen right     ',x,y+2,white+_blue);
  174.  dspat('screenup    - moves a screen up        ',x,y+3,white+_blue);
  175.  dspat('screendown  - moves a screen down      ',x,y+4,white+_blue);
  176.  
  177. savescreen(screenptr^,1,1,80,25);
  178.  
  179. for loop := 1 to 5 do
  180.   begin
  181.     screenleft(screenptr^,x,y,39,5);
  182.     delay(dtime);
  183.   end;
  184. for loop := 1 to 5 do
  185.   begin
  186.     screenup(screenptr,x,y,39,5);
  187.     delay(dtime);
  188.   end;
  189. for loop := 1 to 20 do
  190.   begin
  191.     screenright(screenptr,x,y,39,5);
  192.     delay(dtime);
  193.   end;
  194. for loop := 1 to 15 do
  195.   begin
  196.     screendown(screenptr,x,y,39,5);
  197.     delay(dtime);
  198.   end;
  199. dispose(screenptr);
  200. end;
  201.  
  202. { -------------------------------------------------------------------------- }
  203.  
  204. begin
  205. clrscr;
  206. dtime := 100;
  207.  
  208. movescreendemo(20);
  209.  
  210. end.
  211.  
  212. boxdemo;
  213. scrolldemo;
  214. fillscreendemo;
  215. savescreendemo;
  216. movescreendemo(50);
  217. statusmsg(' And now the same with no delays.....');
  218. movescreendemo(0);
  219. ch := get_key;
  220. end.
  221.  
  222.  
  223.  
  224.  
  225.  
  226.