home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / HTMIX20.ZIP / UNITS.ZIP / SCREEN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-11  |  22.3 KB  |  731 lines
  1. unit Screen;
  2. {┌──────────────────────────────────────────────────────────────────────────┐}
  3. {│                                                                          │}
  4. {│   File    : SCREEN.PAS                                                   │}
  5. {│   Author  : Harald Thunem                                                │}
  6. {│   Purpose : Screen routines                                              │}
  7. {│   Updated : February 16 1992                                             │}
  8. {│                                                                          │}
  9. {└──────────────────────────────────────────────────────────────────────────┘}
  10.  
  11. {────────────────────────────────────────────────────────────────────────────}
  12. interface
  13. {────────────────────────────────────────────────────────────────────────────}
  14.  
  15. uses Dos;
  16.  
  17. const
  18.  
  19.   { Common foreground attributes }
  20.   Black       = $00;      DarkGray       = $08;
  21.   Blue        = $01;      LightBlue      = $09;
  22.   Green       = $02;      LightGreen     = $0A;
  23.   Cyan        = $03;      LightCyan      = $0B;
  24.   Red         = $04;      LightRed       = $0C;
  25.   Magenta     = $05;      LightMagenta   = $0D;
  26.   Brown       = $06;      Yellow         = $0E;
  27.   LightGray   = $07;      White          = $0F;
  28.  
  29.   { Common background attributes }
  30.   BlackBG     = $00;
  31.   BlueBG      = $10;
  32.   GreenBG     = $20;
  33.   CyanBG      = $30;
  34.   RedBG       = $40;
  35.   MagentaBG   = $50;
  36.   BrownBG     = $60;
  37.   LightGrayBG = $70;
  38.  
  39.   { New background attributes, for use with high intensity attributes }
  40.   LightBlackBG   = $80;
  41.   LightBlueBG    = $90;
  42.   LightGreenBG   = $A0;
  43.   LightCyanBG    = $B0;
  44.   LightRedBG     = $C0;
  45.   LightMagentaBG = $D0;
  46.   LightBrownBG   = $E0;
  47.   LightWhiteBG   = $F0;
  48.  
  49.   { Other attributes }
  50.   Blink       = $80;      SameAttr       = -1;
  51.  
  52.   { Different border types }
  53.   NoBorder     = 0;       EmptyBorder  = '      ';
  54.   SingleBorder = 1;       SBorder      = '┌─┐│┘└';
  55.   DoubleBorder = 2;       DBorder      = '╔═╗║╝╚';
  56.   DTopSSide    = 3;       DSBorder     = '╒═╕│╛╘';
  57.   STopDSide    = 4;       SDBorder     = '╓─╖║╜╙';
  58.  
  59.   { Text fonts, 25, 28 or 43/50 rows }
  60.   Font25      = 1;
  61.   Font28      = 2;
  62.   Font50      = 3;
  63.   MaxLines    = 25;
  64.  
  65. type
  66.  
  67.   ScrType  = array[1..MaxLines*80] of word; { Array large enough to store }
  68.   PScrType = ^ScrType;                      { a 25 line screen image      }
  69.  
  70. var
  71.  
  72.   CRTRows,                       { Number of rows }
  73.   CRTCols,                       { Number of columns }
  74.   VideoMode : byte;              { Video-mode }
  75.   ScrVar    : PScrType;          { Screen type pointer variable }
  76.   ScrFile   : file of ScrType;   { File in which to save screen }
  77.  
  78. { Cursor sizes, initialized by ScrInit }
  79.   CursorInitial,
  80.   CursorOff,
  81.   CursorUnderline,
  82.   CursorHalfBlock,
  83.   CursorBlock : word;
  84.  
  85.  
  86. procedure Delay(ms: word);
  87. procedure CursorPos(var Row,Col : byte);
  88. procedure GoToRC(Row,Col : byte);
  89. function EosCol : byte;
  90. function EosRow : byte;
  91. procedure EosToRC(Row,Col : byte);
  92. procedure GoToEos;
  93. procedure GetCursor(var Cursor : word);
  94. procedure SetCursor(Cursor : word);
  95. function ReadAttr(Row,Col : byte) : byte;
  96. function ReadChar(Row,Col : byte) : char;
  97. procedure WriteStr(Row,Col:byte; Attr:integer; S : string);
  98. procedure WriteEos(Attr : integer; S : string);
  99. procedure WriteC(Row,Col:byte; Attr:integer; S : string);
  100. procedure Attr(Row,Col,Rows,Cols,Attr : integer);
  101. procedure FillCh(Row,Col,Rows,Cols : integer; C : char);
  102. procedure Fill(Row,Col,Rows,Cols,Attr : integer; C : char);
  103. procedure ScrollUp(Row,Col,Rows,Cols,BlankAttr:byte);
  104. procedure ScrollDown(Row,Col,Rows,Cols,BlankAttr:byte);
  105. procedure StoreToMem(Row,Col,Rows,Cols : byte; var Dest );
  106. procedure StoreToScr(Row,Col,Rows,Cols : byte; var Source );
  107. procedure ClrScr;
  108. function ShadowAttr(Attr : byte) : byte;
  109. procedure AddShadow(Row,Col,Rows,Cols : byte);
  110. procedure Box(Row,Col,Rows,Cols,Attr,Border:byte;  FillCh:char);
  111. procedure Explode(Row,Col,Rows,Cols,Attr,Border:byte);
  112. procedure GetFont(var CRTRows : byte);
  113. procedure SetFont(Font : byte);
  114. function GetVideoMode : byte;
  115. procedure SetVideoMode(Mode : byte);
  116. procedure SetIntens;
  117. procedure SetBlink;
  118. procedure SaveScreenToFile(ScrFilename: string);
  119. function LoadScreenFromFile(ScrFilename: string): boolean;
  120. procedure ScrInit;
  121.  
  122.  
  123. {────────────────────────────────────────────────────────────────────────────}
  124. implementation
  125. {────────────────────────────────────────────────────────────────────────────}
  126.  
  127.  
  128. var EosOfs    : word;        { Offset of EndOfString marker }
  129.     Regs      : registers;   { Register variable }
  130.     VideoSeg  : word;        { Video segment address }
  131.  
  132.  
  133. procedure Delay(ms: word);
  134. {┌─────────────────────────────────────────────────────────────────┐}
  135. {│  Same as CRT.Delay                                              │}
  136. {└─────────────────────────────────────────────────────────────────┘}
  137. var cx,dx: word;
  138. begin
  139.   cx := Trunc(ms/65.536);
  140.   dx := Trunc(65536*(ms/65.536-cx));
  141.   FillChar(Regs,SizeOf(Regs),0);
  142.   Regs.AH := $86;
  143.   Regs.CX := cx;
  144.   Regs.DX := dx;
  145.   Intr($15,Regs);
  146. end;
  147.  
  148.  
  149. procedure CursorPos(var Row,Col : byte);
  150. {┌─────────────────────────────────────────────────────────────────┐}
  151. {│  Returns the cursor position in Row and Col                     │}
  152. {└─────────────────────────────────────────────────────────────────┘}
  153. begin
  154.   FillChar(Regs,SizeOf(Regs),0);
  155.   Regs.AH := $03;
  156.   Regs.BH := $00;   { Page 0 }
  157.   Intr($10,Regs);
  158.   Row := Regs.DH;
  159.   Col := Regs.DL;
  160. end;
  161.  
  162.  
  163. procedure GoToRC(Row,Col : byte);
  164. {┌─────────────────────────────────────────────────────────────────┐}
  165. {│  Moves the cursor to Row and Col                                │}
  166. {│  Does not update the End-Of-String marker. Use EosToRC (below)  │}
  167. {└─────────────────────────────────────────────────────────────────┘}
  168. begin
  169.   if Row>CRTRows then Exit;
  170.   if Col>CRTCols then Exit;
  171.   FillChar(Regs,SizeOf(Regs),0);
  172.   Regs.AH := $02;
  173.   Regs.DH := Row-1;
  174.   Regs.DL := Col-1;
  175.   Intr($10,Regs);
  176. end;
  177.  
  178.  
  179. function EosCol : byte;
  180. {┌─────────────────────────────────────────────────────────────────┐}
  181. {│  Returns the column number for the End-Of-String marker         │}
  182. {└─────────────────────────────────────────────────────────────────┘}
  183. begin
  184.   EosCol := (EosOfs mod 80);
  185. end;
  186.  
  187.  
  188. function EosRow : byte;
  189. {┌─────────────────────────────────────────────────────────────────┐}
  190. {│  Returns the row number for the End-Of-String marker            │}
  191. {└─────────────────────────────────────────────────────────────────┘}
  192. begin
  193.   EosRow := (EosOfs div 80);
  194. end;
  195.  
  196.  
  197. procedure EosToRC(Row,Col : byte);
  198. {┌─────────────────────────────────────────────────────────────────┐}
  199. {│  Moves the End-Of-String marker to the current cursor position  │}
  200. {└─────────────────────────────────────────────────────────────────┘}
  201. begin
  202.   if Row>CRTRows then Exit;
  203.   if Col>CRTCols then Exit;
  204.   EosOfs := (Row-1)*80 + (Col-1);
  205. end;
  206.  
  207.  
  208. procedure GoToEos;
  209. {┌─────────────────────────────────────────────────────────────────┐}
  210. {│  Moves the cursor to the position of the End-Of-String marker   │}
  211. {└─────────────────────────────────────────────────────────────────┘}
  212. begin
  213.   GoToRC(EosRow+1,EosCol+1);
  214. end;
  215.  
  216.  
  217. procedure GetCursor(var Cursor : word);
  218. {┌─────────────────────────────────────────────────────────────────┐}
  219. {│  Returns the cursor size                                        │}
  220. {└─────────────────────────────────────────────────────────────────┘}
  221. var S,E: byte;
  222. begin
  223.   E := Mem[$0040:$0060];
  224.   S := Mem[$0040:$0061];
  225.   Cursor := (E shl 4) + S;
  226. end;
  227.  
  228.  
  229. procedure SetCursor(Cursor : word);
  230. {┌─────────────────────────────────────────────────────────────────┐}
  231. {│  Sets the cursor size                                           │}
  232. {└─────────────────────────────────────────────────────────────────┘}
  233. begin
  234.   FillChar(Regs,SizeOf(Regs),0);
  235.   Regs.AH := $01;
  236.   Regs.CH := Cursor mod 16;       { Start }
  237.   Regs.CL := Cursor div 16;       { End }
  238.   Intr($10,Regs);
  239.   if (Cursor = CursorOff) and (VideoMode=$07) then GoToRC(1,81);
  240. end;
  241.  
  242.  
  243. function ReadAttr(Row,Col : byte) : byte;
  244. {┌─────────────────────────────────────────────────────────────────┐}
  245. {│  Returns the attribute at position Row,Col                      │}
  246. {└─────────────────────────────────────────────────────────────────┘}
  247. var Offset: word;
  248. begin
  249.   ReadAttr := $00;
  250.   if Row>CRTRows then Exit;
  251.   if Col>CRTCols then Exit;
  252.   Offset := ((Row-1)*80 + (Col-1))*2;
  253.   ReadAttr := Mem[VideoSeg:Offset+1];
  254. end;
  255.  
  256.  
  257. function ReadChar(Row,Col : byte) : char;
  258. {┌─────────────────────────────────────────────────────────────────┐}
  259. {│  Returns the character at position Row,Col                      │}
  260. {└─────────────────────────────────────────────────────────────────┘}
  261. var Offset: word;
  262. begin
  263.   ReadChar := ' ';
  264.   if Row>CRTRows then Exit;
  265.   if Col>CRTCols then Exit;
  266.   Offset := ((Row-1)*80 + (Col-1))*2;
  267.   ReadChar := Chr(Mem[VideoSeg:Offset]);
  268. end;
  269.  
  270.  
  271. procedure WriteStr(Row,Col:byte; Attr:integer; S : string);
  272. {┌─────────────────────────────────────────────────────────────────┐}
  273. {│  Writes the string S at Row,Col using attributes Attr           │}
  274. {└─────────────────────────────────────────────────────────────────┘}
  275. var i     : byte;
  276.     Offset: word;
  277. begin
  278.   if Row>CRTRows then Exit;
  279.   if Col>CRTCols then Exit;
  280.   Offset := ((Row-1)*80 + (Col-1))*2;
  281.   if Attr = SameAttr then
  282.   for i := 1 to Length(S) do
  283.   begin
  284.     Mem[VideoSeg:Offset] := Byte(Ord(S[i]));
  285.     Inc(Offset,2);
  286.   end
  287.   else for i := 1 to Length(S) do
  288.   begin
  289.     MemW[VideoSeg:Offset] := Word((Attr shl 8) + Ord(S[i]));
  290.     Inc(Offset,2);
  291.   end;
  292.   EosOfs := Offset div 2;
  293. end;
  294.  
  295.  
  296. procedure WriteEos(Attr : integer; S : string);
  297. {┌─────────────────────────────────────────────────────────────────┐}
  298. {│  Writes the string S at the End-Of-String marker using          │}
  299. {│  attributes Attr                                                │}
  300. {└─────────────────────────────────────────────────────────────────┘}
  301. var i     : byte;
  302.     Offset: word;
  303. begin
  304.   Offset := EosOfs * 2;
  305.   if Attr = SameAttr then
  306.   for i := 1 to Length(S) do
  307.   begin
  308.     Mem[VideoSeg:Offset] := Byte(Ord(S[i]));
  309.     Inc(Offset,2);
  310.   end
  311.   else for i := 1 to Length(S) do
  312.   begin
  313.     MemW[VideoSeg:Offset] := Word(Attr shl 8 + Ord(S[i]));
  314.     Inc(Offset,2);
  315.   end;
  316.   EosOfs := Offset div 2;
  317. end;
  318.  
  319.  
  320. procedure WriteC(Row,Col:byte; Attr:integer; S : string);
  321. {┌─────────────────────────────────────────────────────────────────┐}
  322. {│  Writes the string S centered about Col at Row                  │}
  323. {└─────────────────────────────────────────────────────────────────┘}
  324. var L: byte;
  325. begin
  326.   L := Length(S) div 2;
  327.   WriteStr(Row,Col-L,Attr,S);
  328. end;
  329.  
  330.  
  331. procedure Attr(Row,Col,Rows,Cols,Attr : integer);
  332. {┌─────────────────────────────────────────────────────────────────┐}
  333. {│  Changes the attributes in Row,Col,Rows,Cols to Attr            │}
  334. {└─────────────────────────────────────────────────────────────────┘}
  335. var i,j   : byte;
  336.     Offset: word;
  337. begin
  338.   if Rows=0 then Exit;
  339.   if Cols=0 then Exit;
  340.   if Rows<0 then  begin  Row:=Row+Rows;  Rows:=-Rows;  end;
  341.   if Cols<0 then  begin  Col:=Col+Cols;  Cols:=-Cols;  end;
  342.   for j := Row to Row+Rows-1 do
  343.   for i := Col to Col+Cols-1 do
  344.   begin
  345.     Offset := ((j-1)*80 + (i-1))*2;
  346.     Mem[VideoSeg:Offset+1] := Attr;
  347.   end;
  348. end;
  349.  
  350.  
  351. procedure FillCh(Row,Col,Rows,Cols : integer; C : char);
  352. {┌─────────────────────────────────────────────────────────────────┐}
  353. {│  Changes the characters in Row,Col,Rows,Cols to C, but leaves   │}
  354. {│  the attribute unchanged.                                       │}
  355. {└─────────────────────────────────────────────────────────────────┘}
  356. var i,j   : byte;
  357.     Offset: word;
  358. begin
  359.   if Rows=0 then Exit;
  360.   if Cols=0 then Exit;
  361.   if Rows<0 then  begin  Row:=Row+Rows;  Rows:=-Rows;  end;
  362.   if Cols<0 then  begin  Col:=Col+Cols;  Cols:=-Cols;  end;
  363.   for j := Row to Row+Rows-1 do
  364.   for i := Col to Col+Cols-1 do
  365.   begin
  366.     Offset := ((j-1)*80 + (i-1))*2;
  367.     Mem[VideoSeg:Offset] := Ord(C);
  368.   end;
  369. end;
  370.  
  371.  
  372. procedure Fill(Row,Col,Rows,Cols,Attr : integer; C : char);
  373. {┌─────────────────────────────────────────────────────────────────┐}
  374. {│  Fills a window with Attr and C                                 │}
  375. {└─────────────────────────────────────────────────────────────────┘}
  376. var i,j   : byte;
  377.     Offset: word;
  378. begin
  379.   if Rows=0 then Exit;
  380.   if Cols=0 then Exit;
  381.   if Rows<0 then  begin  Row:=Row+Rows;  Rows:=-Rows;  end;
  382.   if Cols<0 then  begin  Col:=Col+Cols;  Cols:=-Cols;  end;
  383.   for j := Row to Row+Rows-1 do
  384.   for i := Col to Col+Cols-1 do
  385.   begin
  386.     Offset := ((j-1)*80 + (i-1))*2;
  387.     MemW[VideoSeg:Offset] := Word(Attr shl 8 + Ord(C));
  388.   end;
  389. end;
  390.  
  391.  
  392. procedure ScrollUp(Row,Col,Rows,Cols,BlankAttr:byte);
  393. {┌─────────────────────────────────────────────────────────────────┐}
  394. {│  Scrolls a window up                                            │}
  395. {└─────────────────────────────────────────────────────────────────┘}
  396. begin
  397.   FillChar(Regs,SizeOf(Regs),0);
  398.   Regs.AH := $06;
  399.   Regs.AL := $01;
  400.   Regs.BH := BlankAttr;
  401.   Regs.CH := Row-1;
  402.   Regs.CL := Col-1;
  403.   Regs.DH := Row+Rows-2;
  404.   Regs.DL := Col+Cols-2;
  405.   Intr($10,Regs);
  406. end;
  407.  
  408.  
  409. procedure ScrollDown(Row,Col,Rows,Cols,BlankAttr:byte);
  410. {┌─────────────────────────────────────────────────────────────────┐}
  411. {│  Scrolls a window down                                          │}
  412. {└─────────────────────────────────────────────────────────────────┘}
  413. begin
  414.   FillChar(Regs,SizeOf(Regs),0);
  415.   Regs.AH := $07;
  416.   Regs.AL := $01;
  417.   Regs.BH := BlankAttr;
  418.   Regs.CH := Row-1;
  419.   Regs.CL := Col-1;
  420.   Regs.DH := Row+Rows-2;
  421.   Regs.DL := Col+Cols-2;
  422.   Intr($10,Regs);
  423. end;
  424.  
  425.  
  426. procedure StoreToMem(Row,Col,Rows,Cols : byte; var Dest );
  427. {┌─────────────────────────────────────────────────────────────────┐}
  428. {│  Stores the background to variable Dest                         │}
  429. {└─────────────────────────────────────────────────────────────────┘}
  430. var i,j                      : byte;
  431.     Offs,Value,Segment,Offset: word;
  432. begin
  433.   Segment := Seg(Dest);
  434.   Offset := Ofs(Dest);
  435.   for j := Row to Row+Rows-1 do
  436.   for i := Col to Col+Cols-1 do
  437.   begin
  438.     Offs := ((j-1)*80 + (i-1))*2;
  439.     MemW[Segment:Offset] := MemW[VideoSeg:Offs];
  440.     Inc(Offset,2);
  441.   end;
  442. end;
  443.  
  444.  
  445. procedure StoreToScr(Row,Col,Rows,Cols : byte; var Source );
  446. {┌─────────────────────────────────────────────────────────────────┐}
  447. {│  Draws the stored values in Source to screen                    │}
  448. {└─────────────────────────────────────────────────────────────────┘}
  449. var i,j                      : byte;
  450.     Offs,Value,Segment,Offset: word;
  451. begin
  452.   Segment := Seg(Source);
  453.   Offset := Ofs(Source);
  454.   for j := Row to Row+Rows-1 do
  455.   for i := Col to Col+Cols-1 do
  456.   begin
  457.     Offs := ((j-1)*80 + (i-1))*2;
  458.     MemW[VideoSeg:Offs] := MemW[Segment:Offset];
  459.     Inc(Offset,2);
  460.   end;
  461. end;
  462.  
  463.  
  464. procedure ClrScr;
  465. {┌─────────────────────────────────────────────────────────────────┐}
  466. {│  Similar to CRT.ClrScr                                          │}
  467. {└─────────────────────────────────────────────────────────────────┘}
  468. begin
  469.   Fill(1,1,CRTRows,CRTCols,LightGray+BlackBG,' ');
  470.   GoToRC(1,1);
  471. end;
  472.  
  473.  
  474. function ShadowAttr(Attr : byte) : byte;
  475. {┌─────────────────────────────────────────────────────────────────┐}
  476. {│  Returns the appropriate attribute for a shadow                 │}
  477. {└─────────────────────────────────────────────────────────────────┘}
  478. var Tmp: byte;
  479. begin
  480.   Tmp := Attr AND $0F;
  481.   if Tmp > 8 then
  482.   Tmp := Tmp - 8;
  483.   ShadowAttr := Tmp;
  484. end;
  485.  
  486.  
  487. procedure AddShadow(Row,Col,Rows,Cols : byte);
  488. {┌─────────────────────────────────────────────────────────────────┐}
  489. {│  Adds a shadow to a box                                         │}
  490. {└─────────────────────────────────────────────────────────────────┘}
  491. var i  : byte;
  492.     Tmp: byte;
  493. begin
  494.   for i := Row+1 to Row+Rows do
  495.   begin
  496.     Tmp := ReadAttr(i,Col+Cols);
  497.     Attr(i,Col+Cols,1,1,ShadowAttr(Tmp));
  498.     Tmp := ReadAttr(i,Col+Cols+1);
  499.     Attr(i,Col+Cols+1,1,1,ShadowAttr(Tmp));
  500.   end;
  501.   for i := Col+2 to Col+Cols+1 do
  502.   begin
  503.     Tmp := ReadAttr(Row+Rows,I);
  504.     Attr(Row+Rows,i,1,1,ShadowAttr(Tmp));
  505.   end;
  506. end;
  507.  
  508.  
  509. procedure Box(Row,Col,Rows,Cols,Attr,Border:byte;  FillCh:char);
  510. {┌─────────────────────────────────────────────────────────────────┐}
  511. {│  Draws a box                                                    │}
  512. {└─────────────────────────────────────────────────────────────────┘}
  513. var i: byte;
  514.     B: string[6];
  515. begin
  516.   if Rows=0 then Exit;
  517.   if Cols=0 then Exit;
  518.   if Rows<0 then  begin  Row:=Row+Rows;  Rows:=-Rows;  end;
  519.   if Cols<0 then  begin  Col:=Col+Cols;  Cols:=-Cols;  end;
  520.   if FillCh <> #0 then
  521.     Fill(Row,Col,Rows,Cols,Attr,FillCh);
  522.   case Border of
  523.     NoBorder     : B := EmptyBorder;
  524.     SingleBorder : B := SBorder;
  525.     DoubleBorder : B := DBorder;
  526.     DTopSSide    : B := DSBorder;
  527.     STopDSide    : B := SDBorder;
  528.   end;
  529.   for I := 0 to Rows-1 do
  530.   begin
  531.     WriteStr(Row+I,Col,Attr,B[4]);
  532.     WriteStr(Row+I,Col+Cols-1,Attr,B[4]);
  533.   end;
  534.   for I := 0 to Cols-1 do
  535.   begin
  536.     WriteStr(Row,Col+I,Attr,B[2]);
  537.     WriteStr(Row+Rows-1,Col+I,Attr,B[2]);
  538.   end;
  539.   WriteStr(Row,Col,Attr,B[1]);
  540.   WriteStr(Row,Col+Cols-1,Attr,B[3]);
  541.   WriteStr(Row+Rows-1,Col,Attr,B[6]);
  542.   WriteStr(Row+Rows-1,Col+Cols-1,Attr,B[5]);
  543. end;
  544.  
  545.  
  546. procedure Explode(Row,Col,Rows,Cols,Attr,Border:byte);
  547. {┌─────────────────────────────────────────────────────────────────┐}
  548. {│  Explodes a box                                                 │}
  549. {└─────────────────────────────────────────────────────────────────┘}
  550. var I,R1,R2,C1,C2 : byte;
  551.     MR,MC,DR,DC : single;
  552. begin
  553.   DR := Rows/11;
  554.   DC := Cols/11;
  555.   MR := Row+Rows/2;
  556.   MC := Col+Cols/2;
  557.   for I := 1 to 5 do
  558.   begin
  559.     R1 := Trunc(MR-I*DR);  R2 := Trunc(2*I*DR);
  560.     C1 := Trunc(MC-I*DC);  C2 := Trunc(2*I*DC);
  561.     Box(R1,C1,R2,C2,Attr,Border,' ');
  562.     Delay(10);
  563.   end;
  564.   Box(Row,Col,Rows,Cols,Attr,Border,' ');
  565. end;
  566.  
  567.  
  568. procedure GetFont(var CRTRows : byte);
  569. {┌─────────────────────────────────────────────────────────────────┐}
  570. {│  Gets the number of rows on the screen                          │}
  571. {└─────────────────────────────────────────────────────────────────┘}
  572. begin
  573.   FillChar(Regs,SizeOf(Regs),0);
  574.   Regs.AH := $11;
  575.   Regs.AL := $30;
  576.   Regs.BH := $02;
  577.   Intr($10,Regs);
  578.   CRTRows := Regs.DL+1;
  579. end;
  580.  
  581.  
  582. procedure SetFont(Font : byte);
  583. {┌─────────────────────────────────────────────────────────────────┐}
  584. {│  Sets the number of rows on the screen : 25, 28 or 43/50        │}
  585. {└─────────────────────────────────────────────────────────────────┘}
  586. begin
  587.   case Font of
  588.     Font25: begin
  589.               FillChar(Regs,SizeOf(Regs),0);
  590.               Regs.AH := $00;
  591.               Regs.AL := VideoMode;
  592.               Intr($10,Regs);
  593.               CRTRows := 25;
  594.             end;
  595.     Font28: begin
  596.               FillChar(Regs,SizeOf(Regs),0);
  597.               Regs.AH := $11;
  598.               Regs.AL := $11;
  599.               Intr($10,Regs);
  600.               GetFont(CRTRows);
  601.             end;
  602.     Font50: begin
  603.               FillChar(Regs,SizeOf(Regs),0);
  604.               Regs.AH := $11;
  605.               Regs.AL := $12;
  606.               Intr($10,Regs);
  607.               GetFont(CRTRows);
  608.             end;
  609.   end;
  610. end;
  611.  
  612.  
  613. function GetVideoMode : byte;
  614. {┌─────────────────────────────────────────────────────────────────┐}
  615. {│  Returns the Video Mode                                         │}
  616. {└─────────────────────────────────────────────────────────────────┘}
  617. begin
  618.   FillChar(Regs,SizeOf(Regs),0);
  619.   Regs.AH := $0F;
  620.   Intr($10,Regs);
  621.   GetVideoMode := Regs.AL;
  622. end;
  623.  
  624.  
  625. procedure SetVideoMode(Mode : byte);
  626. {┌─────────────────────────────────────────────────────────────────┐}
  627. {│  Sets the Video Mode                                            │}
  628. {└─────────────────────────────────────────────────────────────────┘}
  629. begin
  630.   if not Mode in [$02,$03,$07] then Exit;
  631.   FillChar(Regs,SizeOf(Regs),0);
  632.   Regs.AH := $00;
  633.   Regs.AL := Mode;
  634.   Intr($10,Regs);
  635. end;
  636.  
  637.  
  638. procedure SetIntens;
  639. {┌─────────────────────────────────────────────────────────────────┐}
  640. {│  Sets mode for 16 foreground and 16 background colors           │}
  641. {└─────────────────────────────────────────────────────────────────┘}
  642. begin
  643.   FillChar(Regs,SizeOf(Regs),0);
  644.   Regs.AH := $10;
  645.   Regs.AL := $03;
  646.   Regs.BL := $00;
  647.   Intr($10,Regs);
  648. end;
  649.  
  650.  
  651. procedure SetBlink;
  652. {┌─────────────────────────────────────────────────────────────────┐}
  653. {│  Sets mode for 16 foreground and 8 background colors and blink  │}
  654. {└─────────────────────────────────────────────────────────────────┘}
  655. begin
  656.   FillChar(Regs,SizeOf(Regs),0);
  657.   Regs.AH := $10;
  658.   Regs.AL := $03;
  659.   Regs.BL := $01;
  660.   Intr($10,Regs);
  661. end;
  662.  
  663.  
  664. procedure SaveScreenToFile(ScrFilename: string);
  665. begin
  666.   GetMem(ScrVar,160*MaxLines);
  667.   StoreToMem(1,1,25,80,ScrVar^);
  668.   Assign(ScrFile,ScrFilename);
  669.   ReWrite(ScrFile);
  670.   Write(ScrFile,ScrVar^);
  671.   Close(ScrFile);
  672.   FreeMem(ScrVar,160*MaxLines);
  673. end;
  674.  
  675.  
  676. function LoadScreenFromFile(ScrFilename: string): boolean;
  677. begin
  678.   GetMem(ScrVar,160*MaxLines);
  679.   {$I-}
  680.   Assign(ScrFile,ScrFilename);
  681.   Reset(ScrFile);
  682.   {$I+}
  683.   if IOResult=0 then
  684.   begin
  685.     Read(ScrFile,ScrVar^);
  686.     Close(ScrFile);
  687.     LoadScreenFromFile := true;
  688.     StoreToScr(1,1,25,80,ScrVar^);
  689.   end
  690.   else LoadScreenFromFile := false;
  691.   FreeMem(ScrVar,160*MaxLines);
  692. end;
  693.  
  694.  
  695. procedure ScrInit;
  696. {┌─────────────────────────────────────────────────────────────────┐}
  697. {│  Initializes some variables                                     │}
  698. {└─────────────────────────────────────────────────────────────────┘}
  699. begin
  700.   VideoMode := GetVideoMode;
  701.   if not VideoMode in [$02,$03,$07] then
  702.   begin
  703.     WriteLn('Wrong video mode !  Halting...');
  704.     Halt(1);
  705.   end;
  706.   GetCursor(CursorInitial);
  707.   CRTCols := 80;
  708.   case VideoMode of
  709.     $02,$03 : begin
  710.             CursorUnderline := 118;  { 6-7 }
  711.             CursorHalfBlock := 116;  { 4-7 }
  712.             CursorBlock     := 113;  { 1-7 }
  713.             CursorOff       := 1;    { 0-1 }
  714.             VideoSeg        := $B800;
  715.           end;
  716.     $07 : begin
  717.             CursorUnderline := 203;  { 11-12 }
  718.             CursorHalfBlock := 198;  {  6-12 }
  719.             CursorBlock     := 193;  {  1-12 }
  720.             CursorOff       := 1;    {  0- 1 }
  721.             VideoSeg        := $B000;
  722.           end;
  723.   end;
  724.   GetFont(CRTRows);
  725. end;
  726.  
  727.  
  728. begin
  729.   ScrInit;
  730. end.
  731.