home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FAQ-S.ZIP / VIDEO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-02-04  |  4.4 KB  |  205 lines
  1. Unit VIDEO;
  2. interface
  3. uses Dos,crt;
  4. type
  5.   screenchars = record
  6.     ch : char;
  7.     at : byte;
  8.     end;
  9.   screens = record
  10.   position : array[1..25,1..80] of ScreenChars;
  11.   x,y : byte;
  12.   end;
  13.   screenType = (mono,color);
  14. var
  15.   stype : screentype;
  16.   vidseg : word;
  17.  
  18. procedure showscreen(var source, video; length : word);
  19. procedure getscreen(var video,source; length: word);
  20. procedure xystring(x,y : byte;s : string;fg,bg : byte);
  21. procedure readscr(var S);
  22. procedure writescr(var s);
  23. procedure horstr(x,y,len : byte;fg,bg : byte;ch : char);
  24. procedure verstr(x,y,len : byte;fg,bg : byte;ch : char);
  25. procedure box(x1,y1,x2,y2 : byte;fg,bg : byte);
  26. procedure center(y : byte;st : string;fg,bg :byte);
  27. procedure boxstring(y:byte;st : string;fg,bg : byte);
  28. procedure fillscreen(var sc : screens;s : string;x,y:byte;fg,bg : byte);
  29. procedure cursoroff;procedure cursorsmall;procedure cursorbig;
  30. implementation
  31. var
  32. regs : registers;
  33. vid : pointer;
  34. procedure showscreen(var source,video;length : word);
  35. begin
  36. if stype = color then
  37.   Inline($90/$90/$90/$90/
  38.          $1E/$55/$BA/$DA/$03/$C5/$B6/ SOURCE /$C4/$BE/ VIDEO /
  39.          $8B/$8E/ LENGTH /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/
  40.          $82/$FB/$FA/$EC/$20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/
  41.          $EA/$5D/$1F)
  42. ELSE
  43. BEGIN
  44. length := length * 2;
  45. move(source,video,length);
  46. end;
  47. end;
  48. procedure GetScreen(var video,source;length : word);
  49. begin
  50. if stype = color then
  51.   inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Video /$C4/$BE/ Source /
  52.          $8B/$8E/Length/$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/
  53.          $D8/$73/$FB/$AD/$FB/$AB/$E2/$F0/$5D/$1F)
  54. ELSE
  55. BEGIN
  56. length := length * 2;
  57. move(source,video,length);
  58. end;
  59. end;
  60. PROCEDURE XYSTRING(X,Y:BYTE;S:STRING;FG,BG:BYTE);
  61. VAR
  62. sa : array[1..255] of record
  63. ch : char;
  64. at : byte;
  65. end;
  66. b,i : byte;
  67. offset : word;
  68. begin
  69. if (length(s) = 0) or
  70. (x>80) or (x<1) or (y>25) or (y<1) then exit;
  71. b := (ord(bg shl 4)) or ord(fg);
  72. fillchar(sa,sizeof(sa),b);
  73. for i := 1 to length(s) do sa[i].ch := s[i];
  74. offset := (((y-1)*80)+(x-1))*2;
  75. vid := ptr(vidseg,offset);
  76. showscreen(sa,vid^,length(s));
  77. end;
  78. procedure readscr(var s);
  79. begin
  80. vid := ptr(vidseg,0);
  81. getscreen(vid^,s,2000);
  82. end;
  83. procedure writescr(var s);
  84. begin
  85. vid := ptr(vidseg,0);
  86. showscreen(s,vid^,2000);
  87. end;
  88. procedure horstr(x,y,len:byte;fg,bg : byte;ch : char);
  89. var
  90. i : byte;
  91. begin
  92. for i := 1 to len do
  93. begin
  94. xystring(x,y,ch,fg,bg);
  95. x := x + 1;
  96. end;
  97. end;
  98. procedure verstr(x,y,len,fg,bg : byte;ch : char);
  99. var
  100. i : byte;
  101. begin
  102. for i := 1 to len do
  103. begin
  104. xystring(x,y,ch,fg,bg);
  105. y := y + 1;
  106. end;
  107. end;
  108. procedure box(x1,y1,x2,y2 : byte;
  109. fg,bg : byte);
  110. begin
  111. if (x1<1) or (x2>80) or (y1<1) or (y2>25) or ((x2 -x1)<2) or ((y2-y1)<2)
  112. then exit;
  113. horstr(x1,y1,1,fg,bg,#201);
  114. horstr(x2,y1,1,fg,bg,#187);
  115. horstr(x1,y2,1,fg,bg,#200);
  116. horstr(x2,y2,1,fg,bg,#188);
  117. verstr(x1,y1+1,y2-y1-1,fg,bg,#186);
  118. verstr(x2,y1+1,y2-y1-1,fg,bg,#186);
  119. horstr(x1+1,y1,x2-x1-1,fg,bg,#205);
  120. horstr(x1+1,y2,x2-x1-1,fg,bg,#205);
  121. end;
  122. procedure center(y:byte;st : string;fg,bg : byte);
  123. var
  124. x : byte;
  125. begin
  126. x := (40-(length(st) div 2));
  127. xystring(x,y,st,fg,bg);
  128. end;
  129. procedure boxstring(y:byte;st : string;fg,bg : byte);
  130. var
  131. x1,y1,x2,y2 : byte;
  132. begin
  133. center(y,st,fg,bg);
  134. x1 := 40-(length(st) div 2)-2;
  135. x2 := x1 + length(st) + 3;
  136. y1 := y - 1;
  137. y2 := y + 1;
  138. box(x1,y1,x2,y2,fg,bg);
  139. end;
  140. procedure fillscreen(var sc : screens;s : string;x,y,fg,bg : byte);
  141. var
  142. i,atx : byte;
  143. begin
  144. atx := fg or (bg shl 4);
  145. for i := 1 to length(s) do
  146. begin
  147. sc.position[y,x].ch := s[i];
  148. sc.position[y,x].at := atx;
  149. x :=x+1;
  150. if x > 80 then
  151. begin
  152. x := 1;
  153. y := y + 1;
  154. if y > 25 then
  155. exit;
  156. end;
  157. end;
  158. end;
  159. procedure cursoroff;
  160. begin
  161. fillchar(regs,sizeof(regs),0);
  162. with regs do
  163. begin
  164. ah := $01;
  165. ch := $20;
  166. cl := $20;
  167. end;
  168. intr($10,regs);
  169. end;
  170. procedure cursorsmall;
  171. begin
  172. fillchar(regs,sizeof(regs),0);
  173. regs.ah := $01;
  174. case stype of
  175. mono : begin
  176. with regs do begin ch:=12;cl :=13;end;end;
  177. color : begin
  178. with regs do begin ch := 6;cl := 7;end;end;end;
  179. intr($10,regs);
  180. end;
  181. procedure cursorbig;
  182. begin
  183. fillchar(regs,sizeof(regs),0);
  184. regs.ah :=1;
  185. regs.ch :=0;
  186. case stype of
  187. mono : regs.cl := 13;
  188. color : regs.cl := 7;
  189. end;
  190. intr($10,regs);end;
  191. begin
  192. fillchar(regs,sizeof(regs),0);
  193. regs.ah := $0F;
  194. intr($10,regs);
  195. if regs.al = 7 then begin
  196. stype := mono;
  197. vidseg := $B000;
  198. end
  199. else
  200. begin
  201. stype := color;
  202. vidseg := $B800;
  203. end;
  204. end.
  205.