home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TP_ADV.ZIP / LIST0607.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-07-31  |  14.8 KB  |  496 lines
  1. {  BIOSCRT - A unit to allow text output through the standard  }
  2. { BIOS calls.  This unit will work in both text and graphics   }
  3. { modes. It was primarily written to allow use of the MS-DOS   }
  4. { system font in graphics mode to compensate for the current   }
  5. { lack of a BGI system font. Note: This method will *NOT* work }
  6. { with most Hercules boards because they don't properly        }
  7. { support the BIOS calls in graphics mode.                     }
  8.  
  9. {  Notes: If you are using this unit on a CGA in the graphics  }
  10. { mode, you should run the GRAFTABL program from your DOS      }
  11. { supplimental program disk (this loads the extended CGA       }
  12. { charater set into memory).                                   }
  13.  
  14. Unit  BiosCrt;
  15.  
  16. interface
  17. uses Dos;
  18.  
  19. var BiosWriteMode   : byte;  { Bios write mode to use for TFDD }
  20.     BiosTextAttr    : byte;  { Bios text attribute byte        }
  21.     BiosStartAttr   : byte;  { Original startup attr           }
  22.     LastBiosMode    : byte;  { last Bios screen mode in use    }
  23.     LastBiosWidth   : byte;  { last Bios screen width used     }
  24.     LastBiosPage    : byte;  { last Bios screen page used      }
  25.  
  26. {--------------------------------------------------------------}
  27. { Below are listed the important Bios variables for the video  }
  28. { display.  These are set by the Bios and are provided for     }
  29. { reading only.  Do not change any of these values or irratic  }
  30. { display operation will result.                               }
  31.  
  32.     BiosMode      : byte absolute $0040:$0049;
  33.     BiosMaxX      : word absolute $0040:$004A;
  34.     BiosCrtLength : word absolute $0040:$004C;
  35.     BiosCursorPos : array [0..7] of word absolute $0040:0050;
  36.     BiosCursorMode: word absolute $0040:$0060;
  37.     BiosActivePage: byte absolute $0040:$0062;
  38.     BiosAddr6845  : word absolute $0040:$0063;
  39.     Bios6845Mode  : byte absolute $0040:$0065;
  40.     BiosPalette   : byte absolute $0040:$0066;
  41.     BiosMaxY      : byte absolute $0040:$0084;
  42.     BiosCharSize  : word absolute $0040:$0085;
  43.     BiosInfo      : byte absolute $0040:$0087;
  44.     BiosInfo3     : byte absolute $0040:$0087;
  45.     BiosFlags     : byte absolute $0040:$0087;
  46.     BiosDCC       : byte absolute $0040:$008A;
  47.     BiosSavePtr   : pointer absolute $0040:$00A8;
  48.     BiosFontTable : byte absolute $F000:$FA6E;
  49.  
  50. { The following are the inline macros used to access the BIOS  }
  51. { routines                                                     }
  52.  
  53. function BiosWhereX:integer;
  54. { get current cursor X pos }
  55. inline(
  56.    $B7/$00     { mov BH,0}
  57.   /$B4/$03     { mov AH,3}
  58.   /$55         { push BP}
  59.   /$CD/$10     { int $10}
  60.   /$5D         { pop BP}
  61.   /$30/$E4     { xor AH,AH}
  62.   /$88/$D0);   { mov AL,DL}
  63.  
  64. function BiosWhereY:integer;
  65. { get current cursor Y pos }
  66. inline(
  67.    $B7/$00     { mov BH,0}
  68.   /$B4/$03     { mov AH,3}
  69.   /$55         { push BP}
  70.   /$CD/$10     { int $10}
  71.   /$5D         { pop BP}
  72.   /$30/$E4     { xor AH,AH}
  73.   /$88/$F0);   { mov AL,DH}
  74.  
  75. procedure BiosWhereXY(var X,Y:integer);
  76. { get current cursor X,Y pos }
  77. inline(
  78.    $B7/$00       { mov BH,0}
  79.   /$B4/$03       { mov AH,3}
  80.   /$55           { push BP}
  81.   /$CD/$10       { int $10}
  82.   /$5D           { pop BP}
  83.   /$07           { pop ES}
  84.   /$5B           { pop BX}
  85.   /$26/$88/$37   { mov ES:[BX],DH}
  86.   /$07           { pop ES}
  87.   /$5B           { pop BX}
  88.   /$26/$88/$17); { mov ES:[BX],DL}
  89.  
  90. procedure BiosGotoXY(X,Y:integer);
  91. { move cursor to indicated X,Y }
  92. inline(
  93.    $58         { pop AX}
  94.   /$5A         { pop DX}
  95.   /$88/$C6     { mov DH,AL}
  96.   /$B7/$00     { mov BH,0}
  97.   /$B4/$02     { mov AH,2}
  98.   /$55         { push BP}
  99.   /$CD/$10     { int $10}
  100.   /$5D);       { pop BP}
  101.  
  102. procedure BiosTextColor(FColor:integer);
  103. { Set text foreground color }
  104. inline(
  105.    $58                   { pop AX}
  106.   /$24/$0f               { and AL,$0F}
  107.   /$8A/$26/>BiosTextAttr { mov AH,[>BiosTextAttr]}
  108.   /$80/$E4/$F0           { and AH,$F0}
  109.   /$08/$E0               { or AL,AH}
  110.   /$A2/>BiosTextAttr);   { mov [>BiosTextAttr],AL}
  111.  
  112. procedure BiosTextBackGround(BColor:integer);
  113. { Set text background color }
  114. inline(
  115.    $58                   { pop AX}
  116.   /$B1/$04               { mov CL,4}
  117.   /$D2/$E0               { shl AL,CL}
  118.   /$8A/$26/>BiosTextAttr { mov AH,[>BiosTextAttr]}
  119.   /$80/$E4/$0F           { and AH,$0F}
  120.   /$08/$E0               { or AL,AH}
  121.   /$A2/>BiosTextAttr);   { mov [>BiosTextAttr],AL}
  122.  
  123. function GetBiosTextAttr:integer;
  124. { Get the current Bios text Attribute }
  125. Inline(
  126.    $B7/$00     { mov BH,0}
  127.   /$B4/$08     { mov AH,8}
  128.   /$55         { push BP}
  129.   /$CD/$10     { int $10}
  130.   /$5D         { pop BP}
  131.   /$88/$E0     { mov AL,AH}
  132.   /$30/$E4);   { xor AH,AH}
  133.  
  134. procedure SetBiosWriteMode(Mode:integer);
  135. { Set Bios write mode to use }
  136. inline(
  137.    $58                   { pop AX}
  138.   /$A2/>BiosWriteMode);  { mov [>BiosWriteMode],AL}
  139.  
  140. procedure SetBiosPage(Page:integer);
  141. { Set active bios video page }
  142. inline(
  143.    $58         { pop AX}
  144.   /$B4/$05     { mov AH,5}
  145.   /$55         { push BP}
  146.   /$CD/$10     { int $10}
  147.   /$5D);       { pop BP}
  148.  
  149. procedure BiosCursorOFF;
  150. { Turn the cursor off }
  151. inline(
  152.    $B4/$03     { mov AH,3}
  153.   /$55         { push BP}
  154.   /$CD/$10     { int $10}
  155.   /$5D         { pop BP}
  156.   /$80/$CD/$20 { or ch,$20}
  157.   /$B4/$01     { mov AH,1}
  158.   /$55         { push BP}
  159.   /$CD/$10     { int $10}
  160.   /$5D);       { pop BP}
  161.  
  162. procedure BiosCursorON;
  163. { Turn the cursor on }
  164. inline(
  165.    $B4/$03     { mov AH,3}
  166.   /$55         { push BP}
  167.   /$CD/$10     { int $10}
  168.   /$5D         { pop BP}
  169.   /$80/$E5/$1F { and CH,$1F}
  170.   /$B4/$01     { mov AH,1}
  171.   /$55         { push BP}
  172.   /$CD/$10     { int $10}
  173.   /$5D);       { pop BP}
  174.  
  175. { The following are the string procedures to access the BIOS   }
  176. { routines                                                     }
  177.  
  178. procedure BiosWrite(S:String);
  179. { Bios based text write }
  180. procedure BiosWriteLn(S:String);
  181. { Bios based text writeln }
  182.  
  183. procedure BiosClrEol;
  184. { Clear to end of line}
  185. procedure BiosClrScr;
  186. { clear the screen }
  187. procedure BiosLowVideo;
  188. { Turns off high intensity attr bit }
  189. procedure BiosHighVideo;
  190. { Turns on high intensity attr bit }
  191. procedure BiosNormalVideo;
  192. { Restores video attr to start up value }
  193. procedure AssignBiosCrt(var F:Text);
  194. { Assigns text output to BiosCrt }
  195. procedure BiosTextMode(Mode:byte);
  196. { Sets new Bios video display mode }
  197. procedure BiosPixGoto(X,Y:integer);
  198. { goto character at pixel location }
  199.  
  200. implementation
  201.  
  202. { The following are the inline macros used to access the BIOS  }
  203. { routines                                                     }
  204.  
  205. { Write Bios character via TTY write }
  206. procedure TtyWrite(Ch:Char; Color:integer);
  207. Inline(
  208.    $5B          { pop BX}
  209.   /$58          { pop AX}
  210.   /$B4/$0E      { mov AH,14}
  211.   /$55          { push BP}
  212.   /$CD/$10      { int $10}
  213.   /$5D);        { pop BP}
  214.  
  215. { Write Bios character via Char/Attribute write }
  216. procedure OutChar(Ch:Char; Color:integer);
  217. Inline(
  218.    $5B          { pop BX}
  219.   /$58          { pop AX}
  220.   /$B9/$01/$00  { mov CX,1}
  221.   /$B4/$09      { mov AH,9}
  222.   /$55          { push BP}
  223.   /$CD/$10      { int $10}
  224.   /$5D);        { pop BP}
  225.  
  226. { This does a Bios based screen scroll }
  227. procedure BiosScrollUp(StartXY,EndXY,Lines:word);
  228. inline(
  229.    $58                   { pop AX}
  230.   /$5A                   { pop DX}
  231.   /$59                   { pop CX}
  232.   /$8A/$3E/>BiosTextAttr { mov BH,[>BiosTextAttr]}
  233.   /$B4/$06               { mov AH,6}
  234.   /$55                   { push BP}
  235.   /$CD/$10               { int $10}
  236.   /$5D);                 { pop BP}
  237.  
  238. { This does a Bios based screen scroll }
  239. procedure BiosScrollDown(StartXY,EndXY,Lines:word);
  240. inline(
  241.    $58                   { pop AX}
  242.   /$5A                   { pop DX}
  243.   /$59                   { pop CX}
  244.   /$8A/$3E/>BiosTextAttr { mov BH,[>BiosTextAttr]}
  245.   /$B4/$07               { mov AH,7}
  246.   /$55                   { push BP}
  247.   /$CD/$10               { int $10}
  248.   /$5D);                 { pop BP}
  249.  
  250. { This updates the LastBios registers prior to a call that     }
  251. { changes them }
  252. procedure SaveLastBiosMode;
  253. inline(
  254.    $B4/$0F                 { mov AH,15}
  255.   /$55                     { push BP}
  256.   /$CD/$10                 { int $10}
  257.   /$5D                     { pop BP}
  258.   /$A2/>LastBiosMode       { mov [>LastBiosMode],AL}
  259.   /$88/$26/>LastBiosWidth  { mov [>LastBiosWidth],AH}
  260.   /$88/$3E/>LastBiosPage); { mov [>LastBiosPage],BH}
  261.  
  262. { Sets the display mode to the values given }
  263. procedure ForceBiosMode(Mode:byte);
  264. inline(
  265.    $58         { pop AX}
  266.   /$B4/$00     { mov AH,0}
  267.   /$55         { push BP}
  268.   /$CD/$10     { int $10}
  269.   /$5D);       { pop BP}
  270.  
  271. { This saves the current Bios display mode in the LastMode     }
  272. { registers }
  273. { Then updates the display to the new mode value given }
  274. procedure BiosTextMode(Mode:byte);
  275. begin
  276.   SaveLastBiosMode;
  277.   ForceBiosMode(Mode);
  278. end;
  279.  
  280. procedure BiosLowVideo;
  281. { Turns off high intensity attr bit }
  282. begin
  283.    BiosTextAttr := BiosTextAttr and $08;
  284. end;
  285.  
  286. procedure BiosHighVideo;
  287. { Turns on high intensity attr bit }
  288. begin
  289.    BiosTextAttr := BiosTextAttr or $08;
  290. end;
  291.  
  292. procedure BiosNormalVideo;
  293. { Restores video attr to start up value }
  294. begin
  295.    BiosTextAttr := BiosStartAttr;
  296. end;
  297.  
  298. { Clear to the end of the text line starting from the current  }
  299. { X position }
  300. procedure BiosClrEol;
  301. var i,x,y : integer;
  302. begin
  303.    BiosWhereXY(x,y);
  304.    for i := BiosWhereX to (BiosMaxX - 2) do
  305.    begin
  306.      TtyWrite(#$20,BiosTextAttr);
  307.    end;
  308.    OutChar(#$20,BiosTextAttr);
  309.    BiosGotoXY(x,y);
  310. end;
  311.  
  312. { Clear the entire screen }
  313. { Warning: in Graphics mode you must set both foreground and   }
  314. { background to the desired color to be used or strange things }
  315. { will happen                                                  }
  316. procedure BiosClrScr;
  317. begin
  318.    if BiosMaxY = 0 then
  319.      BiosScrollUp(0,(24 shl 8) or pred(BiosMaxX),0)
  320.    else
  321.      BiosScrollUp(0,(BiosMaxY shl 8) or pred(BiosMaxX),0);
  322. end;
  323.  
  324. { Delete a line from the screen }
  325. { Warning: in Graphics mode you must set both foreground and   }
  326. { background to the desired color to be used or strange things }
  327. { will happen                                                  }
  328. procedure BiosDelLine;
  329. begin
  330.    if BiosMaxY = 0 then
  331.      BiosScrollUp(BiosWhereY shl 8,(24 shl 8)
  332.        or pred(BiosMaxX),0)
  333.    else
  334.      BiosScrollUp(BiosWhereY shl 8,(BiosMaxY shl 8)
  335.        or pred(BiosMaxX),0);
  336. end;
  337.  
  338. { Insert a line on the screen }
  339. { Warning: in Graphics mode you must set both foreground and   }
  340. { background to the desired color to be used or strange things }
  341. { will happen                                                  }
  342. procedure BiosInsLine;
  343. begin
  344.    if BiosMaxY = 0 then
  345.      BiosScrollDown(BiosWhereY shl 8,(24 shl 8)
  346.        or pred(BiosMaxX),0)
  347.    else
  348.      BiosScrollDown(BiosWhereY shl 8,(BiosMaxY shl 8)
  349.        or pred(BiosMaxX),0);
  350. end;
  351.  
  352. { goto to the closest character X,Y point based on the Pixel   }
  353. { X,Y coordinate                                               }
  354. procedure BiosPixGoto(X,Y:integer);
  355. var CxSize,CySize : integer;
  356. begin
  357.    CySize := BiosCharSize;
  358.    if CySize = 0 then CySize := 8;
  359.    CxSize := 8;
  360.    BiosGotoXY(X div CxSize,Y div CySize);
  361. end;
  362.  
  363. procedure BWrite(Attr,Count:integer; Buf:Pointer);
  364. type BufArray = array[0..65521] of char;
  365.      BufPtr = ^BufArray;
  366. var  P : BufPtr;
  367.      i : integer;
  368. begin
  369.    P := Buf;
  370.    i := 0;
  371.    While i < Count do
  372.    begin
  373.      TtyWrite(P^[i],Attr);
  374.      inc(i);
  375.    end;
  376. end;
  377.  
  378. procedure BkWrite(FColor,BColor,Count:integer; Buf:Pointer);
  379. type BufArray = array[0..65521] of char;
  380.      BufPtr = ^BufArray;
  381. var  P : BufPtr;
  382.      i : integer;
  383. begin
  384.    P := Buf;
  385.    i := 0;
  386.    While i < Count do
  387.    begin
  388.      OutChar(#10,BColor);            { Output a block character}
  389.      OutChar(#9,BColor or $80);      { Fill in the hole        }
  390.      TtyWrite(P^[i],(BColor xor FColor) or $80);
  391.                                      { Then write char         }
  392.      inc(i);
  393.    end;
  394. end;
  395.  
  396. procedure FastBkWrite(FColor,BColor,Count:integer; Buf:Pointer);
  397. type BufArray = array[0..65521] of char;
  398.      BufPtr = ^BufArray;
  399. var  P : BufPtr;
  400.      i : integer;
  401. begin
  402.    P := Buf;  { this works just like BkWrite, but assumes that }
  403.    i := 0;    { the #219 character is available in the system  }
  404.    While i < Count do
  405.                { for CGA systems this means that you must run  }
  406.    begin       { the GRAFTABL program from your DOS disk first }
  407.      OutChar(#219,BColor);          { Output a block character }
  408.      TtyWrite(P^[i],(BColor xor FColor) or $80);
  409.                                     { Then write char          }
  410.      inc(i);
  411.    end;
  412. end;
  413.  
  414. { Write a string via the Bios TTY write function               }
  415. procedure BiosWrite(S:String);
  416. begin
  417.  
  418.    case BiosWriteMode of
  419.      1 : BWrite((BiosTextAttr and $0f)
  420.            or $80,Length(S),Addr(S[1]));
  421.      2 : BkWrite(BiosTextAttr and $0f,(BiosTextAttr shr 4)
  422.            and $0f, Length(S),Addr(S[1]));
  423.      3 : FastBkWrite(BiosTextAttr and $0f,(BiosTextAttr shr 4)
  424.            and $0f, Length(S),Addr(S[1]));
  425.    else
  426.      BWrite(BiosTextAttr and $0f,Length(S),Addr(S[1]));
  427.    end;
  428. end;
  429.  
  430. { Same thing as BiosWrite, but with CRLF added                 }
  431. procedure BiosWriteLn(S:String);
  432. begin
  433.    BiosWrite(S);
  434.    TtyWrite(#10,BiosTextAttr);
  435.    TtyWrite(#13,BiosTextAttr);
  436. end;
  437.  
  438. { The following are the procedures which allows BiosWrite to   }
  439. { use the TFDD                                                 }
  440.  
  441. {$F+}   { force fall calls for TFDD }
  442.  
  443. {-- Ignore this function call --}
  444. function TfddBiosIgnore(var F:TextRec):integer;
  445. begin
  446.    TfddBiosIgnore := 0;
  447. end;
  448.  
  449. {--------------------------------------------------------------------------}
  450. {-- Write a string via the Bios TTY write function --}
  451. {-- background is palette(0) - (usually black) --}
  452. function TfddBiosWrite(var F:TextRec):integer;
  453. begin
  454.    with F do
  455.    begin
  456.      case BiosWriteMode of
  457.        1 : BWrite((BiosTextAttr and $0f) or $80,BufPos,BufPtr);
  458.        2 : BkWrite(BiosTextAttr and $0f,(BiosTextAttr shr 4) and
  459.              $0f, BufPos,BufPtr);
  460.        3 : FastBkWrite(BiosTextAttr and $0f,(BiosTextAttr shr 4)
  461.              and $0f, BufPos,BufPtr);
  462.      else
  463.        BWrite(BiosTextAttr and $0f,BufPos,BufPtr);
  464.      end;
  465.      BufPos := 0;
  466.    end;
  467.    TfddBiosWrite := 0;
  468. end;
  469.  
  470. {$F-}  { finished with the local TFDD so return world to normal }
  471.  
  472. procedure AssignBiosCrt(var F:Text);
  473. begin
  474.    with TextRec(F) do
  475.    begin
  476.      Handle := $FFFF;
  477.      Mode := fmClosed;
  478.      BufSize := SizeOf(Buffer);
  479.      BufPtr := @@Buffer;
  480.      OpenFunc := @@TfddBiosIgnore;
  481.      CloseFunc := @@TfddBiosIgnore;
  482.      FlushFunc := @@TfddBiosWrite;
  483.      InOutFunc := @@TfddBiosWrite;
  484.      Name[0] := #0;
  485.    end;
  486. end;
  487.  
  488. { init with current known attribute by reading the screen }
  489. begin
  490.    BiosStartAttr := GetBiosTextAttr;
  491.    BiosTextAttr := BiosStartAttr;
  492.    BiosWriteMode := 0;
  493.    SaveLastBiosMode;
  494. end.
  495.  
  496.