home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / htscreen / htscreen.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-01-13  |  12.6 KB  |  546 lines
  1. UNIT HtScreen;
  2. {$N+}
  3. INTERFACE
  4.  
  5. USES Dos;
  6.  
  7. CONST
  8.  
  9.   { Common foreground attributes }
  10.   Black       = $00;      DarkGray       = $08;
  11.   Blue        = $01;      LightBlue      = $09;
  12.   Green       = $02;      LightGreen     = $0A;
  13.   Cyan        = $03;      LightCyan      = $0B;
  14.   Red         = $04;      LightRed       = $0C;
  15.   Magenta     = $05;      LightMagenta   = $0D;
  16.   Brown       = $06;      Yellow         = $0E;
  17.   LightGray   = $07;      White          = $0F;
  18.   Blink       = $80;      SameAttr       = -1;
  19.  
  20.   { Common background attributes }
  21.   BlackBG     = $00;
  22.   BlueBG      = $10;
  23.   GreenBG     = $20;
  24.   CyanBG      = $30;
  25.   RedBG       = $40;
  26.   MagentaBG   = $50;
  27.   BrownBG     = $60;
  28.   LightGrayBG = $70;
  29.  
  30.   { Different border types }
  31.   NoBorder     = 0;
  32.   SingleBorder = 1;
  33.   DoubleBorder = 2;
  34.   DTopSSide    = 3;
  35.   STopDSide    = 4;
  36.  
  37.   { Text fonts, 25 or 43/50 rows }
  38.   EGA43Font   = 1;
  39.   NormalFont  = 2;
  40.  
  41. VAR CRTRows,                 { Number of rows }
  42.     CRTCols,                 { Number of columns }
  43.     VideoMode : BYTE;        { Video-mode }
  44.     Fk        : BOOLEAN;     { Function key pressed }
  45.  
  46. { Cursor sizes, initialized by HtInit }
  47.     CursorInitial,
  48.     CursorOff,
  49.     CursorUnderline,
  50.     CursorHalfBlock,
  51.     CursorBlock : WORD;
  52.  
  53.  
  54. FUNCTION HtReadKey(VAR Fk:BOOLEAN) : CHAR;
  55. PROCEDURE HtDelay(MS : REAL);
  56. PROCEDURE GoToRC(Row,Col : BYTE);
  57. FUNCTION EosCol : BYTE;
  58. FUNCTION EosRow : BYTE;
  59. PROCEDURE EosToRC(Row,Col : BYTE);
  60. PROCEDURE GoToEos;
  61. PROCEDURE GetCursor(VAR Cursor : WORD);
  62. PROCEDURE SetCursor(Cursor : WORD);
  63. FUNCTION HtReadAttr(Row,Col : BYTE) : BYTE;
  64. FUNCTION HtReadChar(Row,Col : BYTE) : CHAR;
  65. PROCEDURE HtWrite(Row,Col:BYTE; Attr:INTEGER; S : STRING);
  66. PROCEDURE HtWriteEos(Attr : INTEGER; S : STRING);
  67. PROCEDURE HtWriteC(Row,Col:BYTE; Attr:INTEGER; S : STRING);
  68. PROCEDURE HtAttr(Row,Col,Rows,Cols,Attr : BYTE);
  69. PROCEDURE HtFill(Row,Col,Rows,Cols,Attr : BYTE; C : CHAR);
  70. PROCEDURE HtScrollUp(Row,Col,Rows,Cols,BlankAttr:BYTE);
  71. PROCEDURE HtScrollDown(Row,Col,Rows,Cols,BlankAttr:BYTE);
  72. PROCEDURE HtStoreToMem(Row,Col,Rows,Cols : BYTE; VAR Dest );
  73. PROCEDURE HtStoreToScr(Row,Col,Rows,Cols : BYTE; VAR Source );
  74. PROCEDURE HtClrScr;
  75. FUNCTION ShadowAttr(Attr : BYTE) : BYTE;
  76. PROCEDURE AddShadow(Row,Col,Rows,Cols : BYTE);
  77. PROCEDURE Box(Row,Col,Rows,Cols,Attr,Border:BYTE;  Fill:CHAR);
  78. PROCEDURE Explode(Row,Col,Rows,Cols,Attr,Border:BYTE);
  79. PROCEDURE GetFont(VAR CRTRows : BYTE);
  80. PROCEDURE SetFont(Font : BYTE);
  81. FUNCTION GetVideoMode : BYTE;
  82. PROCEDURE SetVideoMode(Mode : BYTE);
  83. PROCEDURE HtInit;
  84.  
  85.  
  86. IMPLEMENTATION
  87.  
  88. CONST
  89.   EmptyBorder  = '      ';
  90.   SBorder      = '┌─┐│┘└';
  91.   DBorder      = '╔═╗║╝╚';
  92.   DSBorder     = '╒═╕│╛╘';
  93.   SDBorder     = '╓─╖║╜╙';
  94.  
  95.   { Error message }
  96.   ErrorStr    : String[20] = ('Wrong video mode');
  97.  
  98. VAR EosOfs    : WORD;        { Offset of EndOfString marker }
  99.     Regs      : REGISTERS;   { Register variable }
  100.     VideoSeg  : WORD;        { Video segment address }
  101.  
  102.  
  103. PROCEDURE HtError(Num : BYTE);
  104. { Writes out the error message }
  105. BEGIN
  106.   WriteLn(ErrorStr[Num]);
  107.   Halt;
  108. END;
  109.  
  110.  
  111. FUNCTION HtReadKey(VAR Fk:BOOLEAN) : CHAR;
  112. { Almost similar to TP ReadKey, except it checks if the key pressed is a }
  113. { function key, and in that case sets Fk = TRUE                          }
  114. BEGIN
  115.   Fk := FALSE;
  116.   FillChar(Regs,SizeOf(Regs),0);
  117.   Regs.AH := $00;
  118.   Intr($16,Regs);
  119.   IF Regs.AL <> 0 THEN
  120.   HtReadKey := Chr(Regs.AL)
  121.   ELSE BEGIN
  122.     HtReadKey := Chr(Regs.AH);
  123.     Fk := TRUE;
  124.   END;
  125. END;
  126.  
  127.  
  128. PROCEDURE HtDelay(MS : REAL);
  129. { Similar to TP Delay }
  130. VAR D1,D2,M : LONGINT;
  131. BEGIN
  132.   M := Round(MS*1000);
  133.   D1 := M DIV 65536;
  134.   D2 := M MOD 65536;
  135.   FillChar(Regs,SizeOf(Regs),0);
  136.   Regs.AH := $86;
  137.   Regs.CX := D1;
  138.   Regs.DX := D2;
  139.   Intr($15,Regs);
  140. END;
  141.  
  142.  
  143. PROCEDURE GoToRC(Row,Col : BYTE);
  144. { Moves the cursor to row R and column C }
  145. BEGIN
  146.   FillChar(Regs,SizeOf(Regs),0);
  147.   Regs.AH := $02;
  148.   Regs.DH := Row-1;
  149.   Regs.DL := Col-1;
  150.   Intr($10,Regs);
  151. END;
  152.  
  153.  
  154. FUNCTION EosCol : BYTE;
  155. { Returns the column number for the End-Of-String marker }
  156. BEGIN
  157.   EosCol := (EosOfs MOD 80);
  158. END;
  159.  
  160.  
  161. FUNCTION EosRow : BYTE;
  162. { Returns the row number for the End-Of-String marker }
  163. BEGIN
  164.   EosRow := (EosOfs DIV 80);
  165. END;
  166.  
  167.  
  168. PROCEDURE EosToRC(Row,Col : BYTE);
  169. { Moves the End-Of-String marker to the current cursor position }
  170. BEGIN
  171.   EosOfs := (Row-1)*80 + (Col-1);
  172. END;
  173.  
  174.  
  175. PROCEDURE GoToEos;
  176. { Moves the cursor to the position of the End-Of-String marker }
  177. BEGIN
  178.   GoToRC(EosRow+1,EosCol+1);
  179. END;
  180.  
  181.  
  182. PROCEDURE GetCursor(VAR Cursor : WORD);
  183. { Returns the cursor size }
  184. VAR S,E : BYTE;
  185. BEGIN
  186.   E := Mem[$0040:$0060];
  187.   S := Mem[$0040:$0061];
  188.   Cursor := (E SHL 4) + S;
  189. END;
  190.  
  191.  
  192. PROCEDURE SetCursor(Cursor : WORD);
  193. { Sets the cursor size }
  194. BEGIN
  195.   FillChar(Regs,SizeOf(Regs),0);
  196.   Regs.AH := $01;
  197.   Regs.CH := Cursor MOD 16;       { Start }
  198.   Regs.CL := Cursor DIV 16;       { End }
  199.   Intr($10,Regs);
  200.   IF (Cursor = CursorOff) AND (VideoMode=$07) THEN GoToRC(1,81);
  201. END;
  202.  
  203.  
  204. FUNCTION HtReadAttr(Row,Col : BYTE) : BYTE;
  205. { Returns the attribute at position Row,Col }
  206. VAR Offset : WORD;
  207. BEGIN
  208.   Offset := ((Row-1)*80 + (Col-1))*2;
  209.   HtReadAttr := Mem[VideoSeg:Offset+1];
  210. END;
  211.  
  212.  
  213. FUNCTION HtReadChar(Row,Col : BYTE) : CHAR;
  214. { Returns the character at position Row,Col }
  215. VAR Offset : WORD;
  216. BEGIN
  217.   Offset := ((Row-1)*80 + (Col-1))*2;
  218.   HtReadChar := Chr(Mem[VideoSeg:Offset]);
  219. END;
  220.  
  221.  
  222. PROCEDURE HtWrite(Row,Col:BYTE; Attr:INTEGER; S : STRING);
  223. { Writes the string S at Row,Col using attributes Attr }
  224. VAR I : BYTE;
  225.     Offset : WORD;
  226. BEGIN
  227.   Offset := ((Row-1)*80 + (Col-1))*2;
  228.   IF Attr = SameAttr THEN
  229.   FOR I := 1 TO Length(S) DO
  230.   BEGIN
  231.     Mem[VideoSeg:Offset] := Ord(S[I]);
  232.     Inc(Offset,2);
  233.   END
  234.   ELSE FOR I := 1 TO Length(S) DO
  235.   BEGIN
  236.     MemW[VideoSeg:Offset] := Attr SHL 8 + Ord(S[I]);
  237.     Inc(Offset,2);
  238.   END;
  239.   EosOfs := Offset DIV 2;
  240. END;
  241.  
  242.  
  243. PROCEDURE HtWriteEos(Attr : INTEGER; S : STRING);
  244. { Writes the string S at the End-Of-String marker using attributes Attr }
  245. VAR I : BYTE;
  246.     Offset : WORD;
  247. BEGIN
  248.   Offset := EosOfs * 2;
  249.   IF Attr = SameAttr THEN
  250.   FOR I := 1 TO Length(S) DO
  251.   BEGIN
  252.     Mem[VideoSeg:Offset] := Ord(S[I]);
  253.     Inc(Offset,2);
  254.   END
  255.   ELSE FOR I := 1 TO Length(S) DO
  256.   BEGIN
  257.     MemW[VideoSeg:Offset] := Attr SHL 8 + Ord(S[I]);
  258.     Inc(Offset,2);
  259.   END;
  260.   EosOfs := Offset DIV 2;
  261. END;
  262.  
  263.  
  264. PROCEDURE HtWriteC(Row,Col:BYTE; Attr:INTEGER; S : STRING);
  265. { Writes the string S centered about Col at Row }
  266. VAR L : BYTE;
  267. BEGIN
  268.   L := Length(S) DIV 2;
  269.   HtWrite(Row,Col-L,Attr,S);
  270. END;
  271.  
  272.  
  273. PROCEDURE HtAttr(Row,Col,Rows,Cols,Attr : BYTE);
  274. { Changes the attributes in Row,Col,Rows,Cols to Attr }
  275. VAR I,J : BYTE;
  276.     Offset : WORD;
  277. BEGIN
  278.   IF Rows<1 THEN Exit;
  279.   IF Cols<1 THEN Exit;
  280.   FOR J := Row TO Row+Rows-1 DO
  281.   FOR I := Col TO Col+Cols-1 DO
  282.   BEGIN
  283.     Offset := ((J-1)*80 + (I-1))*2;
  284.     Mem[VideoSeg:Offset+1] := Attr;
  285.   END;
  286. END;
  287.  
  288.  
  289. PROCEDURE HtFill(Row,Col,Rows,Cols,Attr : BYTE; C : CHAR);
  290. { Fills a window with Attr and C }
  291. VAR I,J : BYTE;
  292.     Offset : WORD;
  293. BEGIN
  294.   IF Rows<1 THEN Exit;
  295.   IF Cols<1 THEN Exit;
  296.   FOR J := Row TO Row+Rows-1 DO
  297.   FOR I := Col TO Col+Cols-1 DO
  298.   BEGIN
  299.     Offset := ((J-1)*80 + (I-1))*2;
  300.     MemW[VideoSeg:Offset] := Attr SHL 8 + Ord(C);
  301.   END;
  302. END;
  303.  
  304.  
  305. PROCEDURE HtScrollUp(Row,Col,Rows,Cols,BlankAttr:BYTE);
  306. { Scrolls a window up }
  307. BEGIN
  308.   FillChar(Regs,SizeOf(Regs),0);
  309.   Regs.AH := $06;
  310.   Regs.AL := $01;
  311.   Regs.BH := BlankAttr;
  312.   Regs.CH := Row-1;
  313.   Regs.CL := Col-1;
  314.   Regs.DH := Row+Rows-2;
  315.   Regs.DL := Col+Cols-2;
  316.   Intr($10,Regs);
  317. END;
  318.  
  319.  
  320. PROCEDURE HtScrollDown(Row,Col,Rows,Cols,BlankAttr:BYTE);
  321. { Scrolls a window down }
  322. BEGIN
  323.   FillChar(Regs,SizeOf(Regs),0);
  324.   Regs.AH := $07;
  325.   Regs.AL := $01;
  326.   Regs.BH := BlankAttr;
  327.   Regs.CH := Row-1;
  328.   Regs.CL := Col-1;
  329.   Regs.DH := Row+Rows-2;
  330.   Regs.DL := Col+Cols-2;
  331.   Intr($10,Regs);
  332. END;
  333.  
  334.  
  335. PROCEDURE HtStoreToMem(Row,Col,Rows,Cols : BYTE; VAR Dest );
  336. { Stores the background to variable Dest }
  337. VAR I,J : BYTE;
  338.     Offs,Value,Segment,Offset : WORD;
  339. BEGIN
  340.   Segment := Seg(Dest);
  341.   Offset := Ofs(Dest);
  342.   FOR J := Row TO Row+Rows-1 DO
  343.   FOR I := Col TO Col+Cols-1 DO
  344.   BEGIN
  345.     Offs := ((J-1)*80 + (I-1))*2;
  346.     MemW[Segment:Offset] := MemW[VideoSeg:Offs];
  347.     Inc(Offset,2);
  348.   END;
  349. END;
  350.  
  351.  
  352. PROCEDURE HtStoreToScr(Row,Col,Rows,Cols : BYTE; VAR Source );
  353. { Draws the stored values in Source to screen }
  354. VAR I,J : BYTE;
  355.     Offs,Value,Segment,Offset : WORD;
  356. BEGIN
  357.   Segment := Seg(Source);
  358.   Offset := Ofs(Source);
  359.   FOR J := Row TO Row+Rows-1 DO
  360.   FOR I := Col TO Col+Cols-1 DO
  361.   BEGIN
  362.     Offs := ((J-1)*80 + (I-1))*2;
  363.     MemW[VideoSeg:Offs] := MemW[Segment:Offset];
  364.     Inc(Offset,2);
  365.   END;
  366. END;
  367.  
  368.  
  369. PROCEDURE HtClrScr;
  370. { Similar to TP ClrScr }
  371. BEGIN
  372.   HtFill(1,1,25,80,LightGray+BlackBG,' ');
  373.   GoToRC(1,1);
  374. END;
  375.  
  376.  
  377. FUNCTION ShadowAttr(Attr : BYTE) : BYTE;
  378. { Returns the appropriate attribute for a shadow }
  379. VAR Tmp : BYTE;
  380. BEGIN
  381.   Tmp := Attr AND $0F;
  382.   IF Tmp > 8 THEN
  383.   Tmp := Tmp - 8;
  384.   ShadowAttr := Tmp;
  385. END;
  386.  
  387.  
  388. PROCEDURE AddShadow(Row,Col,Rows,Cols : BYTE);
  389. { Adds a shadow to a box }
  390. VAR I : BYTE;
  391.     Tmp : BYTE;
  392. BEGIN
  393.   FOR I := Row TO Row+Rows+1 DO
  394.   BEGIN
  395.     Tmp := HtReadAttr(I,Col+Cols+1);
  396.     HtAttr(I,Col+Cols+1,1,1,ShadowAttr(Tmp));
  397.     Tmp := HtReadAttr(I,Col+Cols+2);
  398.     HtAttr(I,Col+Cols+2,1,1,ShadowAttr(Tmp));
  399.   END;
  400.   FOR I := Col+1 TO Col+Cols DO
  401.   BEGIN
  402.     Tmp := HtReadAttr(Row+Rows+1,I);
  403.     HtAttr(Row+Rows+1,I,1,1,ShadowAttr(Tmp));
  404.   END;
  405. END;
  406.  
  407.  
  408. PROCEDURE Box(Row,Col,Rows,Cols,Attr,Border:BYTE;  Fill:CHAR);
  409. { Draws a box }
  410. VAR  I : BYTE;
  411.      B : STRING[6];
  412. BEGIN
  413.   IF Fill <> #0 THEN
  414.     HtFill(Row,Col,Rows,Cols,Attr,Fill);
  415.   CASE Border OF
  416.     NoBorder     : B := EmptyBorder;
  417.     SingleBorder : B := SBorder;
  418.     DoubleBorder : B := DBorder;
  419.     DTopSSide    : B := DSBorder;
  420.     STopDSide    : B := SDBorder;
  421.   END;
  422.   IF Rows=0 THEN Exit;
  423.   FOR I := 0 TO Rows-1 DO
  424.   BEGIN
  425.     HtWrite(Row+I,Col-1,Attr,B[4]);
  426.     HtWrite(Row+I,Col+Cols,Attr,B[4]);
  427.   END;
  428.   IF Cols=0 THEN Exit;
  429.   FOR I := 0 TO Cols-1 DO
  430.   BEGIN
  431.     HtWrite(Row-1,Col+I,Attr,B[2]);
  432.     HtWrite(Row+Rows,Col+I,Attr,B[2]);
  433.   END;
  434.   HtWrite(Row-1,Col-1,Attr,B[1]);
  435.   HtWrite(Row-1,Col+Cols,Attr,B[3]);
  436.   HtWrite(Row+Rows,Col-1,Attr,B[6]);
  437.   HtWrite(Row+Rows,Col+Cols,Attr,B[5]);
  438. END;
  439.  
  440.  
  441. PROCEDURE Explode(Row,Col,Rows,Cols,Attr,Border:BYTE);
  442. { Explodes a box }
  443. VAR I,R1,R2,C1,C2 : BYTE;
  444.     MR,MC,DR,DC : SINGLE;
  445. BEGIN
  446.   DR := Rows/11;
  447.   DC := Cols/11;
  448.   MR := Row+Rows/2;
  449.   MC := Col+Cols/2;
  450.   FOR I := 1 TO 5 DO
  451.   BEGIN
  452.     R1 := Trunc(MR-I*DR);  R2 := Trunc(2*I*DR);
  453.     C1 := Trunc(MC-I*DC);  C2 := Trunc(2*I*DC);
  454.     Box(R1,C1,R2,C2,Attr,Border,' ');
  455.     HtDelay(10);
  456.   END;
  457.   Box(Row,Col,Rows,Cols,Attr,Border,' ');
  458. END;
  459.  
  460.  
  461. PROCEDURE GetFont(VAR CRTRows : BYTE);
  462. { Gets the number of rows on the screen }
  463. BEGIN
  464.   FillChar(Regs,SizeOf(Regs),0);
  465.   Regs.AH := $11;
  466.   Regs.AL := $30;
  467.   Regs.BH := $02;
  468.   Intr($10,Regs);
  469.   CRTRows := Regs.DL+1;
  470. END;
  471.  
  472.  
  473. PROCEDURE SetFont(Font : BYTE);
  474. { Sets the number of rows on the screen : 25 or 43/50 }
  475. BEGIN
  476.   IF Font=NormalFont THEN
  477.   BEGIN
  478.     FillChar(Regs,SizeOf(Regs),0);
  479.     Regs.AH := $00;
  480.     Regs.AL := VideoMode;
  481.     Intr($10,Regs);
  482.     CRTRows := 25;
  483.   END
  484.   ELSE BEGIN
  485.     FillChar(Regs,SizeOf(Regs),0);
  486.     Regs.AH := $11;
  487.     Regs.AL := $12;
  488.     Regs.BH := $00;
  489.     Intr($10,Regs);
  490.     GetFont(CRTRows);
  491.   END;
  492. END;
  493.  
  494.  
  495. FUNCTION GetVideoMode : BYTE;
  496. { Returns the Video Mode }
  497. BEGIN
  498.   FillChar(Regs,SizeOf(Regs),0);
  499.   Regs.AH := $0F;
  500.   Intr($10,Regs);
  501.   GetVideoMode := Regs.AL;
  502. END;
  503.  
  504.  
  505. PROCEDURE SetVideoMode(Mode : BYTE);
  506. { Sets the video mode }
  507. BEGIN
  508.   IF NOT Mode IN [$02,$03,$07] THEN Exit;
  509.   FillChar(Regs,SizeOf(Regs),0);
  510.   Regs.AH := $00;
  511.   Regs.AL := Mode;
  512.   Intr($10,Regs);
  513. END;
  514.  
  515.  
  516. PROCEDURE HtInit;
  517. { Initializes some variables }
  518. BEGIN
  519.   VideoMode := GetVideoMode;
  520.   IF NOT VideoMode IN [$02,$03,$07] THEN HtError(0);  { Wrong video mode }
  521.   GetCursor(CursorInitial);
  522.   CRTCols := 80;
  523.   CASE VideoMode OF
  524.     $02,$03 : BEGIN
  525.             CursorUnderline := 118;  { 6-7 }
  526.             CursorHalfBlock := 116;  { 4-7 }
  527.             CursorBlock     := 113;  { 1-7 }
  528.             CursorOff       := 1;    { 0-1 }
  529.             VideoSeg        := $B800;
  530.           END;
  531.     $07 : BEGIN
  532.             CursorUnderline := 203;  { 11-12 }
  533.             CursorHalfBlock := 198;  {  6-12 }
  534.             CursorBlock     := 193;  {  1-12 }
  535.             CursorOff       := 1;    {  0- 1 }
  536.             VideoSeg        := $B000;
  537.           END;
  538.   END;
  539.   GetFont(CRTRows);
  540. END;
  541.  
  542.  
  543. BEGIN
  544.   HtInit;
  545. END.
  546.