home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / toolkid / iostuff.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-04-05  |  12.5 KB  |  363 lines
  1. UNIT IOSTUFF;
  2. INTERFACE
  3. USES CRT,DOS;
  4.   TYPE
  5.   AnyStr   = String[80];
  6.   ShortStr = String[20];
  7.   LongStr  = String[160];
  8.   Map      = Record
  9.              ScrCh : Char;
  10.              ScrAt : Byte;
  11.              End;
  12.   Screen = Array[1..25,1..80] of Map;
  13.   VAR
  14.   Color : Boolean;
  15.   CS    : Screen Absolute $B800:0000;
  16.   MS    : Screen Absolute $B000:0000;
  17.   PROCEDURE MoveToScreen(Var Source,Dest; Len: Integer);
  18.   PROCEDURE MoveFromScreen(Var Source,Dest; Len: Integer);
  19.   PROCEDURE SaveScreen(NS:Integer);
  20.   PROCEDURE RestoreScreen(NS:Integer);
  21.   PROCEDURE SavePartScreen(X1,Y1,X2,Y2:Integer);
  22.   PROCEDURE RestorePartScreen(X1,Y1,X2,Y2:Integer);
  23.   PROCEDURE SetColor(F,B:integer);
  24.   PROCEDURE WriteSt(St:AnyStr;X,Y:Integer);
  25.   PROCEDURE WriteCh(Ch:Char;X,Y:Integer);
  26.   PROCEDURE FillScr(Ch:Char);
  27.   FUNCTION  ReadFromScr(X,Y,Len:Integer):AnyStr;
  28.   FUNCTION  GetCh(X,Y:Integer):Char;
  29.   PROCEDURE Border(X1,Y1,X2,Y2: Integer; Header:AnyStr);
  30.   PROCEDURE SBorder(X1,Y1,X2,Y2: Integer; Header:AnyStr);
  31.   PROCEDURE Beep;
  32.   PROCEDURE Linecursor;
  33.   PROCEDURE BigCursor;
  34.   PROCEDURE HideCursor;
  35.   PROCEDURE ShowCursor;
  36. IMPLEMENTATION
  37. VAR
  38.     ScreenHold : Array[0..5] of Screen;
  39.     PartHold   : Screen;
  40.     R          : Registers;
  41.     NS         : Integer;
  42. {======================================================================}
  43. PROCEDURE CheckColorAdapter;
  44.  
  45. { Checks for the existence of a Color adapter.  Sets Color variable }
  46. { to true if it finds the CGA else sets Color to false.  Color is   }
  47. { an external variable that can be checked anywhere in your program }
  48. { to verify if a CGA is present or not. }
  49.  
  50. BEGIN
  51.    If (Mem[0000:1040] and 48) <> 48   { Check memory at 1040 }
  52.              then Color := true
  53.              else Color := False;
  54. END;
  55.  
  56. {======================================================================}
  57. PROCEDURE MoveToScreen(Var Source,Dest; Len: Integer);
  58.  
  59. { Similar to Turbo Move but assumes the destination is in video  }
  60. { memory and thus writes only during retrace to avoid snow.      }
  61. { These are used only in Save and Restore Screen routines below. }
  62. { These routines are very fast and can be used as the basic      }
  63. { building blocks for other direct screen IO.  I have used Turbo }
  64. { Pascals regular Write routines whereever possible because they }
  65. { are sufficiently fast and much more understandable and stable. }
  66.  
  67.   Begin
  68.       Len:=Len Shr 1;
  69.       Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Dest /$8B/$8E/
  70.              Len /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/$72/$FB/$FA/$EC/
  71.              $20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/$EA/$5D/$1F);
  72.   End;
  73.  
  74. {======================================================================}
  75. PROCEDURE MoveFromScreen(Var Source,Dest; Len: Integer);
  76.  
  77. { Similar to Turbo Move but assumes the source is in video  }
  78. { memory and thus writes only during retrace to avoid snow. }
  79.  
  80.   Begin
  81.       Len:=Len Shr 1;
  82.       Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Dest /$8B/$8E/
  83.              Len /$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/$D8/$73/$FB/$AD/
  84.              $FB/$AB/$E2/$F0/$5D/$1F);
  85.   End;
  86.  
  87. {======================================================================}
  88. PROCEDURE SaveScreen(NS:Integer);
  89. BEGIN
  90.   If Color then MoveFromScreen(CS,ScreenHold[NS],4000)
  91.            else Move(MS,ScreenHold[NS],4000);
  92. END;
  93.  
  94. {======================================================================}
  95. PROCEDURE RestoreScreen(NS:Integer);
  96. BEGIN
  97.   If Color then MoveToScreen(ScreenHold[NS],CS,4000)
  98.            else Move(ScreenHold[NS],MS,4000);
  99. END;
  100.  
  101. {======================================================================}
  102. PROCEDURE SavePartScreen(X1,Y1,X2,Y2:Integer);
  103. VAR
  104.   II,XLen : Integer;
  105. BEGIN
  106.   XLen := (X2-X1+1)*2;
  107.   For II := Y1 to Y2 do begin
  108.     If Color then MoveFromScreen(CS[II,X1],ScreenHold[0,II,X1],XLen) { avoid snow }
  109.              else Move(MS[II,X1],ScreenHold[0,II,X1],XLen);
  110.   End;
  111. END;
  112.  
  113. {======================================================================}
  114. PROCEDURE RestorePartScreen(X1,Y1,X2,Y2:Integer);
  115. VAR
  116.   II,XLen : Integer;
  117. BEGIN
  118.   XLen := (X2-X1+1)*2;
  119.   For II := Y1 to Y2 do begin
  120.     If Color then MoveToScreen(ScreenHold[0,II,X1],CS[II,X1],XLen) { avoid snow }
  121.              else Move(ScreenHold[0,II,X1],MS[II,X1],XLen);
  122.   End;
  123. END;
  124.  
  125. {======================================================================}
  126. PROCEDURE SetColor(F,B:integer);
  127.  
  128. { This sets variable TextAttr in Unit CRT to the colors F and B }
  129. { The approach is equivalent to TextColor(F); TextBackground(B);}
  130. { except blink is handled directly (any B > 7)}
  131.  
  132. BEGIN
  133.  TextAttr := F + B * 16;
  134. END;
  135.  
  136. {======================================================================}
  137. PROCEDURE WriteSt(St:AnyStr;X,Y:Integer);
  138.  
  139. { Much output is strings.  This routine saves all the GOTOXYs}
  140.  
  141. BEGIN
  142.   GoToXY(X,Y);
  143.   Write(St);
  144. END;
  145.  
  146. {======================================================================}
  147. PROCEDURE WriteCh(Ch:Char;X,Y:Integer);
  148.  
  149. { Service 9, Intr 10 is used because it will write the "unwriteable" }
  150. { low numbered ASCII characters like #07, which produces a beep if   }
  151. { written with a regular Write statement }
  152.  
  153.   BEGIN
  154.       GoToXY(X,Y);             { Put cursor at location }
  155.       R.AH := $09;             { Load A Hi with Service 9 }
  156.       R.BL := TextAttr;        { Load B Lo with Attribute }
  157.       R.BH := 0;               { Load B Hi with Screen 0 }
  158.       R.AL := Ord(Ch);         { Load A Lo with Character to write }
  159.       R.CX := 1;               { Load C with number of times to write (1) }
  160.       Intr($10,R);             { Do Interrupt 10 }
  161.  
  162.   END;
  163.  
  164. {======================================================================}
  165. PROCEDURE WriteManyCh(Ch:Char;X,Y,Num:Integer);
  166.  
  167. { Like WriteCh above except repeats the character Num times. }
  168.  
  169.   BEGIN
  170.       GoToXY(X,Y);
  171.       R.AH := $09;
  172.       R.BL := TextAttr;
  173.       R.BH := 0;
  174.       R.AL := Ord(Ch);
  175.       R.CX := Num;
  176.       Intr($10,R);
  177.  
  178.   END;
  179.  
  180. {======================================================================}
  181. PROCEDURE FillScr(Ch:Char);
  182.  
  183. { Fills the screen with the character passed }
  184.  
  185.   BEGIN
  186.       GoToXY(1,1);
  187.       R.AH := $09;
  188.       R.BL := TextAttr;
  189.       R.BH := 0;
  190.       R.AL := Ord(Ch);
  191.       R.CX := 2000;
  192.       Intr($10,R);
  193.  
  194.   END;
  195.  
  196. {======================================================================}
  197. FUNCTION ReadFromScr(X,Y,Len:Integer):AnyStr;
  198.  
  199. { Uses service 8 of Intr 10 to read a string off the screen }
  200. { The cursor tends to flicker across the screen if this routine }
  201. { is used continuously so the cursor is turned off while it is }
  202. { working by flipping bit 5 of the top scan line to 1 }
  203.  
  204. VAR
  205.    TempStr : AnyStr;
  206.    II,L    : Integer;
  207. BEGIN
  208.                             { turn off the cursor }
  209.    R.AX := $0300;           { Service 3 }
  210.    Intr($10,R);             { Interrupt 10 to get cursor scan lines}
  211.    R.CX := R.CX or $2000;   { Set bit 5 of top scan line to 1 }
  212.    R.AX := $0100;           { Service 1 }
  213.    Intr($10,R);             { Interrupt 10 to turn off }
  214.  
  215.    L := 0;
  216.    For II := 1 to Len Do Begin
  217.      GoToXY(X+II-1,Y);      { Locate cursor }
  218.  
  219.                             { Read a character from the screen }
  220.      R.AX := $0800;         { Service 8 }
  221.      R.BH := 0;             { Screen 0 }
  222.      Intr($10,R);           { Interrupt 10 }
  223.      TempStr[II] := Chr(R.AL);            { Char returned in AL }
  224.      If TempStr[II] <> ' ' then L := II   { if non blank remember length }
  225.    End;
  226.                             { flip the cursor back on }
  227.    R.AX := $0300;           { Service 3 again }
  228.    Intr($10,R);             { Interrupt 10 to get scan lines }
  229.    R.CX := R.CX and $DFFF;  { Flip bit 5 of top scan line to 0 }
  230.    R.AX := $0100;           { Service 1 }
  231.    Intr($10,R);             {Interrupt 10 to turn on cursor }
  232.  
  233.    TempStr[0] := Chr(L);    { Set the string length to last non blank char. }
  234.    ReadFromScr := TempStr;  { Set function result to temporary string }
  235.  END;
  236. {======================================================================}
  237. FUNCTION GetCh(X,Y:Integer):Char;
  238.  
  239. { Reads a character from the screen using service 8, Intr 10 }
  240.  
  241. BEGIN
  242.  
  243.    GoToXY(X,Y);            { Locate the cursor }
  244.  
  245.    R.AX := $0800;          { Service 8 }
  246.    R.BH := 0;              { Screen 0 }
  247.    Intr($10,R);            { Interrupt 10 }
  248.    GetCh := Chr(R.AL);     { Character returned in AL }
  249.  
  250.  END;
  251.  
  252. {======================================================================}
  253. PROCEDURE Border(X1,Y1,X2,Y2: Integer; Header:AnyStr);
  254.  
  255. { Prints a double line box border on the screen with corners at }
  256. { X1,Y1 and X2,Y2.  The Header will be center on the top.  }
  257.  
  258. VAR Indx : Integer;
  259. BEGIN
  260.    WriteCh('╔',X1,Y1);                      { Upper left corner }
  261.    WriteManyCh('═',X1+1,Y1,X2-X1-1);        { Top }
  262.    WriteCh('╗',X2,Y1);                      { Upper right corner }
  263.    For Indx := Y1+1 to Y2-1 do              { Both sides }
  264.     Begin
  265.      WriteCh('║',X1,Indx);
  266.      WriteCh('║',X2,Indx);
  267.     End;
  268.    WriteCh('╚',X1,Y2);                      { lower left corner }
  269.    WriteManyCh('═',X1+1,Y2,X2-X1-1);        { bottom }
  270.    WriteCh('╝',X2,Y2);                      { lower right corner }
  271.    If Header > '' then                      { Center header }
  272.    WriteSt('╡'+Header+'╞',X1+(X2-X1) div 2-((Length(Header)+1) div 2),Y1);
  273. END;
  274.  
  275. {======================================================================}
  276. PROCEDURE SBorder(X1,Y1,X2,Y2: Integer; Header:AnyStr);
  277.  
  278. { Prints a single line box border on the screen with corners at }
  279. { X1,Y1 and X2,Y2.  The Header will be centered on the top.  }
  280.  
  281. VAR Indx : Integer;
  282. BEGIN
  283.    WriteCh('┌',X1,Y1);                      { Upper left corner }
  284.    WriteManyCh('─',X1+1,Y1,X2-X1-1);        { Top }
  285.    WriteCh('┐',X2,Y1);                      { Upper right corner }
  286.    For Indx := Y1+1 to Y2-1 do              { Both sides }
  287.     Begin
  288.      WriteCh('│',X1,Indx);
  289.      WriteCh('│',X2,Indx);
  290.     End;
  291.    WriteCh('└',X1,Y2);                      { lower left corner }
  292.    WriteManyCh('─',X1+1,Y2,X2-X1-1);        { bottom }
  293.    WriteCh('┘',X2,Y2);                      { lower right corner }
  294.    If Header > '' then                      { Center header }
  295.    WriteSt('┤'+Header+'├',X1+(X2-X1) div 2-((Length(Header)+1) div 2),Y1);
  296. END;
  297.  
  298. {======================================================================}
  299. PROCEDURE Beep;
  300.  BEGIN
  301.  Sound(550); Delay(200); Nosound;
  302.  END;
  303.  
  304. {======================================================================}
  305. PROCEDURE Linecursor;
  306.  
  307. { Sets the cursor to two lines.  Checks type of adapter because }
  308. { Monochrome has more scan lines than CGA/EGA }
  309.  
  310.   Begin
  311.     R.AX := $0100;                   { Service 1 }
  312.     If (Mem[0000:1040]and 48)<>48    { Check for CGA }
  313.              then R.CX := $0607      { Color Adapter }
  314.              else R.CX := $0C0D;     { Mono Adapter }
  315.     Intr($10,R);                     { Interrupt 10 }
  316.   End;
  317.  
  318. {======================================================================}
  319. PROCEDURE Bigcursor;
  320.  
  321. { Sets the cursor to a large block to signify insert.  As above }
  322. { checks adapter }
  323.   Begin
  324.     R.AX := $0100;                    { Service 1 }
  325.     If (Mem[0000:1040]and 48)<>48     { Check for CGA }
  326.              then R.CX := $0107       { Color Adapter }
  327.              else R.CX := $010D;      { Mono Adapter }
  328.     Intr($10,R);                      { Interrupt 10 }
  329.   End;
  330.  
  331. {======================================================================}
  332. PROCEDURE HideCursor;
  333.  
  334. { Turns cursor off by flipping bit 5 of top scan line to 1.    }
  335. { This is a better cursor hiding technique than moving it off  }
  336. { the screen because you can still do GoToXY and the cursor is }
  337. { invisible. }
  338.  
  339.   BEGIN
  340.        R.AX := $0300;               { Service 3 }
  341.        Intr($10,R);                 { Intr 10. Get scan lines}
  342.        R.CX := R.CX or $2000;       { Set bit 5 to 1}
  343.        R.AX := $0100;               { Service 1 }
  344.        Intr($10,R);                 { Intr 10 resets cursor}
  345.   END;
  346.  
  347. {======================================================================}
  348. PROCEDURE ShowCursor;
  349. { Turns cursor on by flipping bit 5 of Top Scan Line back to 0 }
  350.  
  351.   BEGIN
  352.        R.AX := $0300;               { Service 3 }
  353.        Intr($10,R);                 { Intr 10. Get scan lines}
  354.        R.CX := R.CX and $DFFF;      { Set bit 5 to 0}
  355.        R.AX := $0100;               { Service 1 }
  356.        Intr($10,R);                 { Intr 10 resets cursor}
  357.   END;
  358.  
  359. {======================================================================}
  360.  
  361. BEGIN {Initilization}
  362.   CheckColorAdapter;
  363. END. {OF UNIT}