home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / TPFAST30.ZIP / TPFAST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-09-26  |  15.5 KB  |  403 lines
  1. {  _______________________________________________________________
  2.   |                                                               |
  3.   |            Copyright (C) 1989,1990  Steven Lutrov             |
  4.   |_______________________________________________________________|____
  5.   |                                                               |    |
  6.   |  Program Title : Tpfast.Pas                                   |    | ___
  7.   |  Author        : Steven Lutrov                                |    |    |
  8.   |  Revision      : 3.00                                         |    |    |
  9.   |  Date          : 1990-07-16                                   |    |    |
  10.   |  Language      : Turbo Pascal 5.5                             |    |    |
  11.   |                                                               |    |    |
  12.   |  Description   : Unit File For All The Assembly Routines      |    |    |
  13.   |                : Fastscr.Asm Faststr.Asm Fastfile.Asm         |    |    |
  14.   |                : Fastgrp.Asm Fastbit.Asm Fastkbd.Asm          |    |    |
  15.   |                                                               |    |    |
  16.   |_______________________________________________________________|    |    |
  17.       |                                                                |    |
  18.       |________________________________________________________________|    |
  19.           |                                                                 |
  20.           |_________________________________________________________________|
  21.  
  22. }
  23.  
  24. Unit  Tpfast;
  25.  
  26.  
  27. { ------------------------------------------------------------------------- }
  28.                                  Interface
  29. { ------------------------------------------------------------------------- }
  30.  
  31. Uses Dos,Crt;
  32.  
  33. { ------------------------------------------------------------------------- }
  34.                                    Type
  35. { ------------------------------------------------------------------------- }
  36.  
  37.        Stype             =  String[80];     { Used For 1 screen line  Etc   }
  38.   Cardtype     = (None,Mda,Cga,Egamono,EgaColour,Vgamono,
  39.                   VgaColour,Mcgamono,McgaColour);
  40.  
  41.  
  42. { ------------------------------------------------------------------------- }
  43.                                     Var
  44. { ------------------------------------------------------------------------- }
  45.  
  46.        Errreturn         :  Byte;     { Global Error Monitor                }
  47.        Video_Buff        :  Word;     { Address Of Video Buffer             }
  48.        Snow_Check        :  Boolean;  { Check For Snow On Screen Writes     }
  49.        Video_Page        :  Byte;     { Video Page Used For Screen Writes   }
  50.        Textattr          :  Byte;     { The Text Attribute Byte Setting     }
  51.        Startline         :  Byte;
  52.        Stopline          :  Byte;
  53.   Textbufbase       : Pointer;    { Pointer to Base address of video screen }
  54.  
  55. { ------------------------------------------------------------------------- }
  56.  
  57. Function  Bytetohex(Work_: Byte): Stype;
  58. Function  Rotatewordleft(Work_: Word; Bits_: Byte): Word;
  59. Function  Rotatebyteright(Work_,Bits_: Byte): Byte;
  60. Function  Rotatebyteleft(Work_,Bits_:Byte): Byte;
  61. Function  Rotatewordright(Work_: Word; Bits_: Byte): Word;
  62. Function  Wordtohex(Work_: Word): Stype;
  63.  
  64. Function  Closefile(Handle:Integer):Boolean;
  65. Function  Createfile(Fname:String; Attribute:Integer):Integer;
  66. Function  Erasefile(Name:String):Integer;
  67. Function  Fmovepointer(Handle,Mode:Integer;Offset:Longint;Var Location: Longint):Boolean;
  68. Function  Getverify: Boolean;
  69. Function  Getvolume(Disk: Integer; Workarea: Pointer): Stype;
  70. Function  Openfile(Name:String; Access:Integer):Integer;
  71. Function  Readfile(Handle:Word; Amount:Word; Var Buff):Integer;
  72. Procedure Readsector(Segment,Offset,Drive,Sector,Number: Word);
  73. Procedure Setverify(Setting: Boolean);
  74. Procedure Setvolume(Disk: Integer; Newlabel: Stype; Workarea: Pointer);
  75. Function  Writefile(Handle:Integer; Nwrite:Word; Var Buff):Integer;
  76. Procedure Writesector(Segment,Offset,Drive,Sector,Number: Word);
  77.  
  78. Procedure Clearpage(Pagenumber,Colour: Byte);
  79. Procedure Copyclear(Box: Pointer; X_Pos,Y_Pos,X_Num,Y_Num,Colour: Byte);
  80. Procedure Drawbox(Char_X ,Char_Y :Char;X_Pos,Y_Pos,X_Num,Y_Num,Colour:Byte);
  81. Procedure Fillscreen(Ch: Char; X_Pos,Y_Pos,X_Num,Y_Num,Colour: Byte);
  82. Procedure Restorescreen(Box: Pointer; X_Pos,Y_Pos,X_Num,Y_Num: Byte);
  83. Procedure Savescreen(Box: Pointer; X_Pos,Y_Pos,X_Num,Y_Num: Byte);
  84. Procedure Screendown(Box: Pointer; Var X_Pos,Y_Pos: Byte; X_Num,Y_Num: Byte);
  85. Procedure Screenleft(Box:Pointer; Var X_Pos,Y_Pos: Byte; X_Num,Y_Num: Byte);
  86. Procedure Screenright(Box:Pointer; Var X_Pos,Y_Pos: Byte; X_Num,Y_Num: Byte);
  87. Procedure Screenup(Box: Pointer; Var X_Pos,Y_Pos: Byte; X_Num,Y_Num: Byte);
  88. Procedure Scrollx(Where: Char; X_Pos,Y_Pos,X_Num,Y_Num,Cols,Colour: Byte);
  89. Procedure Scrolly(Where: Char; X_Pos,Y_Pos,X_Num,Y_Num,Lines,Colour: Byte);
  90. Procedure Swappage(Box: Pointer; Pagenumber: Byte);
  91.  
  92. Function  Altkeydown: Boolean;
  93. Function  Capslockdown: Boolean;
  94. Function  Capslockon: Boolean;
  95. Procedure Clearbuffer;
  96. Procedure Clearcapslock;
  97. Procedure Clearins;
  98. Procedure Clearnumlock;
  99. Procedure Clearscrolllock;
  100. Function  Ctrlkeydown: Boolean;
  101. Function  Freshchar: Char;
  102. Function  Getscan: Byte;
  103. Function  Inskeydown: Boolean;
  104. Function  Inskeyon: Boolean;
  105. Procedure Keypause(Code: Char; Ascii: Boolean; Wait_A,Wait_B: Byte);
  106. Function  Lastkey: Char;
  107. Function  Leftshiftdown: Boolean;
  108. Function  Nextkey: Char;
  109. Function  Numlockdown: Boolean;
  110. Function  Numlockon: Boolean;
  111. Function  Readchar: Char;
  112. Function  Rightshiftdown: Boolean;
  113. Function  Scrolllockdown: Boolean;
  114. Function  Scrolllockon: Boolean;
  115. Procedure Setcapslock;
  116. Procedure Setins;
  117. Procedure Setnumlock;
  118. Procedure Setscrolllock;
  119.  
  120. Procedure Background(Code: Char);
  121. Procedure Blinkoff;
  122. Procedure Blinkon;
  123. Procedure Colourx(X_Pos,Y_Pos,Y_Pos,Colour: Byte);
  124. Procedure Cursordown(Y_Pos: Integer);
  125. Procedure Cursorleft(Columns: Integer);
  126. Procedure Cursoroff;
  127. Procedure Cursoron;
  128. Procedure Cursorright(Columns: Integer);
  129. Procedure Cursorup(Y_Pos: Integer);
  130. Procedure Dsp(Strx: Stype);
  131. Procedure Dspat(Strx: Stype; X_Pos,Y_Pos,Colour: Byte);
  132. Procedure Dspcolour(Strx: Stype; Colour: Byte);
  133. Procedure Dspend(Strx: Stype; X_Pos,Y_Pos,Length,Colour: Byte);
  134. Procedure Dspjust(Strx: Stype; X_Pos,Y_Pos,Colour: Byte);
  135. Procedure Dspln(Strx: Stype);
  136. Procedure Dsplncolour(Strx: Stype; Colour: Byte);
  137. Procedure Dsppart(Strx: Stype; Start,Numch,X_Pos,Y_Pos,Colour: Byte);
  138. Procedure Dspvert(Strx: Stype; X_Pos,Y_Pos,Colour: Byte);
  139. Procedure Foreground(Code: Char);
  140. Procedure Formatleft(Strx: Stype; How_Many: Integer; Colour: Byte);
  141. Procedure Formatright(Strx: Stype; How_Many: Integer; Colour: Byte);
  142. Function  Getcolour(X_Pos,Y_Pos: Byte): Byte;
  143. Function  Getpage: Integer;
  144. Procedure Intenseoff;
  145. Procedure Intenseon;
  146. Procedure Normal;
  147. Procedure Reverse;
  148. Procedure Rowcolour(X_Pos,Y_Pos,X_Num,Colour: Byte);
  149. Procedure Screencolour(X_Pos,Y_Pos,X_Num,Y_Pos,Colour: Byte);
  150. Procedure Setcolour(X_Pos,Y_Pos,Colour: Byte);
  151. Procedure Setpage(Pagenumber: Integer);
  152.  
  153. Procedure Changechar(Var Strx: Stype; Search,Replace: Char);
  154. Function  Compare(Strg1,Strg2: Stype): Boolean;
  155. Procedure Deletechar(Var Strx: Stype; Ch: Char);
  156. Procedure Deleteleft(Var Strx: Stype; Border: Char);
  157. Procedure Deleteright(Var Strx: Stype; Border: Char);
  158. Function  Leftend(Var Strx: Stype; Border: Char): Stype;
  159. Procedure Lowercase(Var Strx: Stype);
  160. Procedure Overwrite(Var Strx: Stype; Substrg: Stype; Position: Integer);
  161. Procedure Padcentre(Var Strx: Stype; Ch: Char; Position,Length: Integer);
  162. Procedure Padends(Var Strx: Stype; Ch: Char; Length: Integer);
  163. Procedure Padleft(Var Strx: Stype; Ch: Char; Length: Integer);
  164. Procedure Padright(Var Strx: Stype; Ch: Char; Length: Integer);
  165. Procedure Replace(Var Strx: Stype; Substrg: Stype; Position,Chars: Integer);
  166. Function  Rightend(Var Strx: Stype; Border: Char): Stype;
  167. Function  Seekstring(Strx,Substrg: Stype; Startpt: Integer):Integer;
  168. Function  Stringend(Strx: Stype; Numberchars: Integer): Stype;
  169. Function  Stringof(Substrg: Stype; Length: Integer): Stype;
  170. Procedure Uppercase(Var Strx: Stype);
  171. Function  Wordcount(Strx: Stype): Integer;
  172.  
  173. { Routines That Are Partially Assembly Written }
  174.  
  175. Procedure Dspc(Strx : Stype ;Y_Pos,Colour:Byte);
  176.  
  177.  
  178. { ------------------------------------------------------------------------- }
  179.                               Implementation
  180. { ------------------------------------------------------------------------- }
  181.  
  182. {$F+}   { Force Far Call Linking }
  183.  
  184. {$L FastBit.Obj}
  185. Function  Bytetohex;External;
  186. Function  Rotatewordleft;External;
  187. Function  Rotatebyteright;External;
  188. Function  Rotatebyteleft;External;
  189. Function  Rotatewordright;External;
  190. Function  Wordtohex;External;
  191.  
  192.  
  193. {$L FastFile.Obj}
  194. Function  Closefile;External;
  195. Function  Createfile;External;
  196. Function  Erasefile;External;
  197. Function  Fmovepointer;External;
  198. Function  Getverify;External;
  199. Function  Getvolume;External;
  200. Function  Openfile;External;
  201. Function  Readfile;External;
  202. Procedure Readsector;External;
  203. Procedure Setverify;External;
  204. Procedure Setvolume;External;
  205. Function  Writefile;External;
  206. Procedure Writesector;External;
  207.  
  208. {$L FastGrp.Obj}
  209. Procedure Clearpage;External;
  210. Procedure Copyclear;External;
  211. Procedure Drawbox;External;
  212. Procedure Fillscreen;External;
  213. Procedure Restorescreen;External;
  214. Procedure Savescreen;External;
  215. Procedure Screendown;External;
  216. Procedure Screenleft;External;
  217. Procedure Screenright;External;
  218. Procedure Screenup;External;
  219. Procedure Scrollx;External;
  220. Procedure Scrolly;External;
  221. Procedure Swappage;External;
  222.  
  223. {$L FastKbd.Obj}
  224. Function  Altkeydown;External;
  225. Function  Capslockdown;External;
  226. Function  Capslockon;External;
  227. Procedure Clearbuffer;External;
  228. Procedure Clearcapslock;External;
  229. Procedure Clearins;External;
  230. Procedure Clearnumlock;External;
  231. Procedure Clearscrolllock;External;
  232. Function  Ctrlkeydown;External;
  233. Function  Freshchar;External;
  234. Function  Getscan;External;
  235. Function  Inskeydown;External;
  236. Function  Inskeyon;External;
  237. Procedure Keypause;External;
  238. Function  Lastkey;External;
  239. Function  Leftshiftdown;External;
  240. Function  Nextkey;External;
  241. Function  Numlockdown;External;
  242. Function  Numlockon;External;
  243. Function  Readchar;External;
  244. Function  Rightshiftdown;External;
  245. Function  Scrolllockdown;External;
  246. Function  Scrolllockon;External;
  247. Procedure Setcapslock;External;
  248. Procedure Setins;External;
  249. Procedure Setnumlock;External;
  250. Procedure Setscrolllock;External;
  251.  
  252. {$L FastScr.Obj}
  253. Procedure Background;External;
  254. Procedure Blinkoff;External;
  255. Procedure Blinkon;External;
  256. Procedure Colourx;External;
  257. Procedure Cursordown;External;
  258. Procedure Cursorleft;External;
  259. Procedure Cursoroff;External;
  260. Procedure Cursoron;External;
  261. Procedure Cursorright;External;
  262. Procedure Cursorup;External;
  263. Procedure Dsp;External;
  264. Procedure Dspat;External;
  265. Procedure Dspcolour;External;
  266. Procedure Dspend;External;
  267. Procedure Dspjust;External;
  268. Procedure Dspln;External;
  269. Procedure Dsplncolour;External;
  270. Procedure Dsppart;External;
  271. Procedure Dspvert;External;
  272. Procedure Foreground;External;
  273. Procedure Formatleft;External;
  274. Procedure Formatright;External;
  275. Function  Getcolour;External;
  276. Function  Getpage;External;
  277. Procedure Intenseoff;External;
  278. Procedure Intenseon;External;
  279. Procedure Normal;External;
  280. Procedure Reverse;External;
  281. Procedure Rowcolour;External;
  282. Procedure Screencolour;External;
  283. Procedure Setcolour;External;
  284. Procedure Setpage;External;
  285.  
  286. {$L FastStr.Obj}
  287. Procedure Changechar;External;
  288. Function  Compare;External;
  289. Procedure Deletechar;External;
  290. Procedure Deleteleft;External;
  291. Procedure Deleteright;External;
  292. Function  Leftend;External;
  293. Procedure Lowercase;External;
  294. Procedure Overwrite;External;
  295. Procedure Padcentre;External;
  296. Procedure Padends;External;
  297. Procedure Padleft;External;
  298. Procedure Padright;External;
  299. Procedure Replace;External;
  300. Function  Rightend;External;
  301. Function  Seekstring;External;
  302. Function  Stringend;External;
  303. Function  Stringof;External;
  304. Procedure Uppercase;External;
  305. Function  Wordcount;External;
  306.  
  307. {$F-}   { Restore  Call Linking }
  308.  
  309. { ------------------------------------------------------------------------- }
  310. Procedure Dspc (Strx : Stype ;Y_Pos,Colour:Byte);
  311.  
  312.   Begin
  313.         Dspat(Strx,40 - Length(Strx) Div 2,Y_Pos,Colour);
  314.   End;
  315.  
  316. { ------------------------------------------------------------------------- }
  317. Function WhatCard : Cardtype;
  318.  
  319.  
  320. Var
  321.   Code : Byte;
  322.   Regs : Registers;
  323.  
  324. Begin
  325.   Regs.Ah := $1A;             { Attempt To Call Vga Identify Card Function }
  326.   Regs.Al := $00;             { Must Clear Al To 0 ...                     }
  327.   Intr($10,Regs);
  328.   If Regs.Al = $1A Then       { So That If $1A Comes Back In Al...         }
  329.     Begin                     { We Know A Ps/2 Video Bios Is Out There.    }
  330.       Case Regs.Bl Of         { Code Comes Back In Bl.                     }
  331.         $00 : WhatCard := None;
  332.         $01 : WhatCard := Mda;
  333.         $02 : WhatCard := Cga;
  334.         $04 : WhatCard := EgaColour;
  335.         $05 : WhatCard := Egamono;
  336.         $07 : WhatCard := Vgamono;
  337.         $08 : WhatCard := VgaColour;
  338.         $0A,$0C : WhatCard := McgaColour;
  339.         $0B : WhatCard := Mcgamono;
  340.         Else WhatCard := Cga
  341.       End { Case }
  342.     End
  343.   Else
  344.                                   { If It'S Not Ps/2 We Have To Check For  }
  345.      Begin                        { The Presence Of An Ega Bios:           }
  346.       Regs.Ah := $12;             { Select Alternate Function Service      }
  347.       Regs.Bx := $10;             { Bl=$10 Means Return Ega Information    }
  348.       Intr($10,Regs);             { Do It                                  }
  349.       If Regs.Bx <> $10 Then      { Bx Unchanged Means Ega Is Not There... }
  350.         Begin
  351.           Regs.Ah := $12;         { Once We Know Alt Function Exists...    }
  352.           Regs.Bl := $10;         { ...We Call It Again To See If It'S...  }
  353.           Intr($10,Regs);         { ...Ega Colour Or Ega Monochrome.       }
  354.           If (Regs.Bh = 0) Then WhatCard := EgaColour
  355.             Else WhatCard := Egamono
  356.         End
  357.       Else
  358.                                   { Now We Know its a Cga Or Mda  Bastard !}
  359.         Begin
  360.           Intr($11,Regs);         { $11 = Equipment Determination Service  }
  361.           Code := (Regs.Al And $30) Shr 4;
  362.           Case Code Of
  363.             1 : WhatCard := Cga;
  364.             2 : WhatCard := Cga;
  365.             3 : WhatCard := Mda
  366.             Else WhatCard := None
  367.           End { Case }
  368.         End
  369.     End;
  370. End;
  371.  
  372. { ------------------------------------------------------------------------- }
  373. Function Gettextbuforigin : Word;
  374. { Jeff Duntemans rule from Doctor Dobbs Journal :                           }
  375. { For Boards Attached To Monochrome Monitors, The Buffer                    }
  376. { Origin Is $B000:0; For Boards Attached To Colour Monitors (Including      }
  377. { All  Composite Monitors And Tv'S) The Buffer Origin Is $B800:0.           }
  378.  
  379. Begin
  380.   Case WhatCard Of
  381.     Cga,
  382.     McgaColour,
  383.     EgaColour,
  384.     VgaColour :  GetTextbuforigin := $B800;
  385.     Mda,
  386.     Mcgamono,
  387.     Egamono,
  388.     Vgamono  :   Gettextbuforigin := $B000;
  389.   End  { Case }
  390. End;
  391.  
  392.  
  393. { ------------------------------------------------------------------------- }
  394. {                          Unit Initialisation                              }
  395. { ------------------------------------------------------------------------- }
  396.  
  397. Begin
  398.      Video_Buff   := Gettextbuforigin;  { Base address                      }
  399.      Snow_Check   := True;              { Change as you wish !              }
  400.      Video_Page   := 0;                 { Initialy Video Page Should 0      }
  401. End.
  402.  
  403.