home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / tp_fast / version4 / tpfast.pas < prev    next >
Pascal/Delphi Source File  |  1991-11-15  |  20KB  |  490 lines
  1. {  _______________________________________________________________
  2.   |                                                               |
  3.   |            CopyRight (c) 1989,1990  Steven Lutrov             |
  4.   |_______________________________________________________________|____
  5.   |                                                               |    |
  6.   |  program title : tpfast.pas                                   |    | ___
  7.   |  author        : Steven Lutrov                                |    |    |
  8.   |  revision      : 4.00                                         |    |    |
  9.   |  date          : 1990-07-16                                   |    |    |
  10.   |  language      : turbo pascal 5.5                             |    |    |
  11.   |                                                               |    |    |
  12.   |  description   : unit file for all the assembly routines      |    |    |
  13.   |                                                               |    |    |
  14.   |_______________________________________________________________|    |    |
  15.       |                                                                |    |
  16.       |________________________________________________________________|    |
  17.           |                                                                 |
  18.           |_________________________________________________________________|
  19.  
  20. }
  21.  
  22. unit  tpfast;
  23.  
  24.  
  25. { ------------------------------------------------------------------------- }
  26.                                  interface
  27. { ------------------------------------------------------------------------- }
  28.  
  29. uses dos,crt;
  30.  
  31. { ------------------------------------------------------------------------- }
  32.                                    type
  33. { ------------------------------------------------------------------------- }
  34.  
  35.        stype        =  string;     { you may want to svae memory and }
  36.                                    { declare stype as string[80] , as it}
  37.                                    { is mostly used for displaying one
  38.                                    { line to the string, beware of pascal }
  39.                                    { strict type checking }
  40.  
  41.        cardtype     =  (none,mda,cga,egamono,egacolour,vgamono,
  42.                         vgacolour,mcgamono,mcgacolour);
  43.  
  44.  
  45. const
  46.  
  47.  
  48.   BackSpc        = 3592;    Tab            = 3849;    Lf             = 10;
  49.   Esc            = 283;     Ins            = 21216;   Del            = 21472;
  50.   Home           = 18400;   Endkey         = 20448;   PgUp           = 18912;
  51.   PgDn           = 20960;   Up             = 18656;   Down           = 20704;
  52.   Left           = 19424;   Right          = 19936;   nIns           = 20992;
  53.   nDel           = 21248;   nHome          = 18176;   nEnd           = 20224;
  54.   nPgUp          = 18688;   nPgDn          = 20736;   nUp            = 18432;
  55.   nDown          = 20480;   nLeft          = 19200;   nRight         = 19712;
  56.   n5             = 19456;   F1             = 15104;   F2             = 15360;
  57.   F3             = 15616;   F4             = 15872;   F5             = 16128;
  58.   F6             = 16384;   F7             = 16640;   F8             = 16896;
  59.   F9             = 17152;   F10            = 17408;   F11            = 34048;
  60.   F12            = 34304;   Space          = 14624;   Enter          = 7181;
  61.  
  62.  
  63.  
  64.   Null           = 0;       CtrlA          = 7681;    CtrlB          = 12290;
  65.   CtrlC          = 11779;   CtrlD          = 8196;    CtrlE          = 4613;
  66.   CtrlF          = 8454;    CtrlG          = 8711;    CtrlH          = 8968;
  67.   CtrlI          = 5897;    CtrlJ          = 9226;    CtrlK          = 9483;
  68.   CtrlL          = 9740;    CtrlM          = 12813;   CtrlN          = 12558;
  69.   CtrlO          = 6159;    CtrlP          = 6416;    CtrlQ          = 4113;
  70.   CtrlR          = 4882;    CtrlS          = 7955;    CtrlT          = 5140;
  71.   CtrlU          = 5653;    CtrlV          = 12054;   CtrlW          = 4375;
  72.   CtrlX          = 11544;   CtrlY          = 5401;    CtrlZ          = 11290;
  73.   CtrlBackSpc    = 3711;    CtrlTab        = 37888;   CtrlIns        = 1024;
  74.   CtrlDel        = 1536;    CtrlHome       = 30688;   CtrlEnd        = 30176;
  75.   CtrlPgUp       = 34016;   CtrlPgDn       = 30432;   CtrlUp         = 36320;
  76.   CtrlDown       = 37344;   CtrlLeft       = 29664;   CtrlRight      = 29920;
  77.   CtrlnIns       = 1024;    CtrlnDel       = 1536;    CtrlnHome      = 30464;
  78.   CtrlnEnd       = 29952;   CtrlnPgUp      = 33792;   CtrlnPgDn      = 30208;
  79.   CtrlnUp        = 36096;   CtrlnDown      = 37120;   CtrlnLeft      = 29664;
  80.   CtrlnRight     = 29696;   Ctrln5         = 36608;   CtrlF1         = 24064;
  81.   CtrlF2         = 24320;   CtrlF3         = 24576;   CtrlF4         = 24832;
  82.   CtrlF5         = 25088;   CtrlF6         = 25344;   CtrlF7         = 25600;
  83.   CtrlF8         = 25856;   CtrlF9         = 26112;   CtrlF10        = 26368;
  84.   CtrlF11        = 35072;   CtrlF12        = 35328;   CtrlSpace      = 14624;
  85.   CtrlEnter      = 7178;
  86.  
  87.   Alt0           = 33024;   Alt1           = 30720;   Alt2           = 30976;
  88.   Alt3           = 31232;   Alt4           = 31488;   Alt5           = 31744;
  89.   Alt6           = 32000;   Alt7           = 32256;   Alt8           = 32512;
  90.   Alt9           = 32768;   AltA           = 7680;    AltB           = 12288;
  91.   AltC           = 11776;   AltD           = 8192;    AltE           = 4608;
  92.   AltF           = 8448;    AltG           = 8704;    AltH           = 8960;
  93.   AltI           = 5888;    AltJ           = 9216;    AltK           = 9472;
  94.   AltL           = 9728;    AltM           = 12800;   AltN           = 12544;
  95.   AltO           = 6144;    AltP           = 6400;    AltQ           = 4096;
  96.   AltR           = 4864;    AltS           = 7936;    AltT           = 5120;
  97.   AltU           = 5632;    AltV           = 12032;   AltW           = 4352;
  98.   AltX           = 11520;   AltY           = 5376;    AltZ           = 11264;
  99.   AltBackSpc     = 3584;    AltTab         = 42240;   AltIns         = 41472;
  100.   AltDel         = 41728;   AltHome        = 38656;   AltEnd         = 40704;
  101.   AltPgUp        = 39168;   AltPgDn        = 41216;   AltUp          = 38912;
  102.   AltDown        = 40960;   AltLeft        = 39680;   AltRight       = 40192;
  103.   AltF1          = 26624;   AltF2          = 26880;   AltF3          = 27136;
  104.   AltF4          = 27392;   AltF5          = 27648;   AltF6          = 27904;
  105.   AltF7          = 28160;   AltF8          = 28416;   AltF9          = 28672;
  106.   AltF10         = 28928;   AltF11         = 35584;   AltF12         = 35840;
  107.   AltSpace       = 512;     AltEnter       = 7168;    AtlEsc         = 256;
  108.  
  109.  
  110.  
  111.   Shift0         = 2857;    Shift1         = 545;     Shift2         = 832;
  112.   Shift3         = 1059;    Shift4         = 1316;    Shift5         = 1573;
  113.   Shift6         = 1886;    Shift7         = 2086;    Shift8         = 2346;
  114.   Shift9         = 2600;
  115.   ShiftBackSpc   = 3592;    ShiftTab       = 3840;    ShiftIns       = 1280;
  116.   ShiftDel       = 1792;    ShiftF1        = 21504;   ShiftF2        = 21760;
  117.   ShiftF3        = 22016;   ShiftF4        = 22272;   ShiftF5        = 22528;   ShiftF6        = 27904;
  118.   ShiftF7        = 23040;   ShiftF8        = 23296;   ShiftF9        = 23552;
  119.   ShiftF10       = 23808;   ShiftF11       = 34560;   ShiftF12       = 34816;
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.  
  128.  
  129.        _black                   = black;
  130.        _blue                    = blue       shl 4;
  131.        _green                   = green      shl 4;
  132.        _cyan                    = cyan       shl 4;
  133.        _red                     = red        shl 4;
  134.        _magenta                 = magenta    shl 4;
  135.        _brown                   = yellow     shl 4;
  136.        _lightgary               = lightgray  shl 4;
  137.  
  138.        { e.g.    blue+_green  = blue foreground on green background }
  139.  
  140.  
  141. var
  142.        TPFError                 :byte;     { global error monitor }
  143.        video_buff               :word;     { address of video buffer  }
  144.        snow_check               :boolean;  { snow check for CGA   }
  145.        video_page               :byte;     { default video page  }
  146.        startline                :byte;     { cursor start scanline}
  147.        stopline                 :byte;     { cursor start scanline}
  148.  
  149.  
  150. { ------------------------------------------------------------------------- }
  151.  
  152. function  bytetohex(num :byte): stype;
  153. function  rotatewordleft(num: word; nbits :byte): word;
  154. function  rotatebyteright(num,nbits :byte) :byte;
  155. function  rotatebyteleft(num,nbits :byte) :byte;
  156. function  rotatewordright(num: word; nbits :byte): word;
  157. function  wordtohex(num: word): stype;
  158.  
  159. function  fclose(handle :integer):boolean;
  160. function  fcreate(fname:string; attribute :integer) :integer;
  161. function  ferase(name:string) :integer;
  162. function  fseek(handle,mode :integer;offset:longint;var location: longint):boolean;
  163. function  getverify: boolean;
  164. function  fopen(name:string; access :integer) :integer;
  165. function  fread(handle:word; amount:word; var buff) :integer;
  166. procedure readsector(segment,offset,drive,sector,number: word);
  167. procedure setverify(setting: boolean);
  168. function  fwrite(handle :integer; nwrite:word; var buff) :integer;
  169. procedure writesector(segment,offset,drive,sector,number: word);
  170.  
  171. procedure copyclear(box :pointer; x,y,xx,yy,colour :byte);
  172. procedure drawbox(char_x ,char_y  :char;x,y,xx,yy,colour :byte);
  173. procedure fillscreen(ch :char; x,y,xx,yy,colour :byte);
  174. procedure restorescreen(box :pointer; x,y,xx,yy :byte);
  175. procedure savescreen(box :pointer; x,y,xx,yy :byte);
  176. procedure screendown(box :pointer; var x,y :byte; xx,yy :byte);
  177. procedure screenleft(box :pointer; var x,y :byte; xx,yy :byte);
  178. procedure screenright(box :pointer; var x,y :byte; xx,yy :byte);
  179. procedure screenup(box :pointer; var x,y :byte; xx,yy :byte);
  180. procedure scrollx(where :char; x,y,xx,yy,cols,colour :byte);
  181. procedure scrolly(where :char; x,y,xx,yy,lines,colour :byte);
  182.  
  183. function  altkeydown: boolean;
  184. function  capslockdown: boolean;
  185. function  capslockon: boolean;
  186. procedure clearbuffer;
  187. procedure clearcapslock;
  188. procedure clearins;
  189. procedure clearnumlock;
  190. procedure clearscrolllock;
  191. function  ctrlkeydown: boolean;
  192. function  ekeypressed :boolean;
  193. function  getekey :word;
  194. function  getkey :word;
  195. function  freshchar :char;
  196. function  inskeydown: boolean;
  197. function  inskeyon: boolean;
  198. procedure keypause(code :char; ascii: boolean; wait_a,wait_b :byte);
  199. function  lastkey :char;
  200. function  leftshiftdown: boolean;
  201. function  nextkey :char;
  202. function  numlockdown: boolean;
  203. function  numlockon: boolean;
  204. function  rightshiftdown: boolean;
  205. function  scrolllockdown: boolean;
  206. function  scrolllockon: boolean;
  207. procedure setcapslock;
  208. procedure setins;
  209. procedure setnumlock;
  210. procedure setscrolllock;
  211.  
  212.  
  213.  
  214.  
  215. procedure background(code :char);
  216. procedure blinkoff;
  217. procedure blinkon;
  218. procedure clearpage(pagenumber,colour :byte);
  219. procedure colourx(x,y,y,colour :byte);
  220. procedure cursordown(y :integer);
  221. procedure cursorleft(columns :integer);
  222. procedure cursoroff;
  223. procedure cursoron;
  224. procedure cursorright(columns :integer);
  225. procedure cursorup(y :integer);
  226. procedure dsp(strx: stype);
  227. procedure dspat(strx: stype; x,y,colour :byte);
  228. procedure dspcolour(strx: stype; colour :byte);
  229. procedure dspend(strx: stype; x,y,length,colour :byte);
  230. procedure dspjust(strx: stype; x,y,colour :byte);
  231. procedure dspln(strx: stype);
  232. procedure dsplncolour(strx: stype; colour :byte);
  233. procedure dsppart(strx: stype; start,numch,x,y,colour :byte);
  234. procedure dspvert(strx: stype; x,y,colour :byte);
  235. procedure foreground(code :char);
  236. procedure formatleft(strx: stype; how_many :integer; colour :byte);
  237. procedure formatright(strx: stype; how_many :integer; colour :byte);
  238. function  getcolour(x,y :byte) :byte;
  239. function  getpage :integer;
  240. procedure intenseoff;
  241. procedure intenseon;
  242. procedure normal;
  243. procedure reverse;
  244. procedure rowcolour(x,y,xx,colour :byte);
  245. procedure screencolour(x,y,xx,y,colour :byte);
  246. procedure setcolour(x,y,colour :byte);
  247. procedure setpage(pagenumber :integer);
  248. procedure swappage(box :pointer; pagenumber :byte);
  249.  
  250. procedure changechar(var strx: stype; search,replace :char);
  251. function  compare(strg1,strg2: stype): boolean;
  252. procedure deletechar(var strx: stype; ch :char);
  253. procedure deleteleft(var strx: stype; border :char);
  254. procedure deleteright(var strx: stype; border :char);
  255. function  leftend(var strx: stype; border :char): stype;
  256. procedure lowercase(var strx: stype);
  257. procedure overwrite(var strx: stype; substrg: stype; position :integer);
  258. procedure padcentre(var strx: stype; ch :char; position,length :integer);
  259. procedure padends(var strx: stype; ch :char; length :integer);
  260. procedure padleft(var strx: stype; ch :char; length :integer);
  261. procedure padright(var strx: stype; ch :char; length :integer);
  262. procedure replace(var strx: stype; substrg: stype; position,chars :integer);
  263. function  rightend(var strx: stype; border :char): stype;
  264. function  seekstring(strx,substrg: stype; startpt :integer) :integer;
  265. function  stringend(strx: stype; numberchars :integer): stype;
  266. function  stringof(substrg: stype; length :integer): stype;
  267. procedure uppercase(var strx: stype);
  268. function  wordcount(strx: stype) :integer;
  269.  
  270. { routines that are partially assembly written }
  271.  
  272. procedure dspc(strx : stype ;y,colour :byte);
  273.  
  274.  
  275. { ------------------------------------------------------------------------- }
  276.                               implementation
  277. { ------------------------------------------------------------------------- }
  278.  
  279. {$F+}   { force far call linking }
  280.  
  281. {$L TPFBIT.OBJ}
  282. function  bytetohex;external;
  283. function  rotatewordleft;external;
  284. function  rotatebyteright;external;
  285. function  rotatebyteleft;external;
  286. function  rotatewordright;external;
  287. function  wordtohex;external;
  288.  
  289.  
  290. {$L TPFFILE.OBJ}
  291. function  fclose;external;
  292. function  fcreate;external;
  293. function  ferase;external;
  294. function  fseek;external;
  295. function  getverify;external;
  296. function  fopen;external;
  297. function  fread;external;
  298. procedure readsector;external;
  299. procedure setverify;external;
  300. function  fwrite;external;
  301. procedure writesector;external;
  302.  
  303. {$L TPFSCRN.OBJ}
  304. procedure clearpage;external;
  305. procedure copyclear;external;
  306. procedure drawbox;external;
  307. procedure fillscreen;external;
  308. procedure restorescreen;external;
  309. procedure savescreen;external;
  310. procedure screendown;external;
  311. procedure screenleft;external;
  312. procedure screenright;external;
  313. procedure screenup;external;
  314. procedure scrollx;external;
  315. procedure scrolly;external;
  316. procedure swappage;external;
  317.  
  318. {$L TPFKBD.OBJ}
  319. function  altkeydown       ;external;
  320. function  capslockdown     ;external;
  321. function  capslockon       ;external;
  322. procedure clearbuffer      ;external;
  323. procedure clearcapslock    ;external;
  324. procedure clearins         ;external;
  325. procedure clearnumlock     ;external;
  326. procedure clearscrolllock  ;external;
  327. function  ctrlkeydown      ;external;
  328. function  ekeypressed      ;external;
  329. function  getekey          ;external;
  330. function  getkey           ;external;
  331. function  freshchar        ;external;
  332. function  inskeydown       ;external;
  333. function  inskeyon         ;external;
  334. procedure keypause         ;external;
  335. function  lastkey          ;external;
  336. function  leftshiftdown    ;external;
  337. function  nextkey          ;external;
  338. function  numlockdown      ;external;
  339. function  numlockon        ;external;
  340. function  rightshiftdown   ;external;
  341. function  scrolllockdown   ;external;
  342. function  scrolllockon     ;external;
  343. procedure setcapslock      ;external;
  344. procedure setins           ;external;
  345. procedure setnumlock       ;external;
  346. procedure setscrolllock    ;external;
  347.  
  348.  
  349. {$L TPFVIDEO.OBJ}
  350. procedure background;external;
  351. procedure blinkoff;external;
  352. procedure blinkon;external;
  353. procedure colourx;external;
  354. procedure cursordown;external;
  355. procedure cursorleft;external;
  356. procedure cursoroff;external;
  357. procedure cursoron;external;
  358. procedure cursorright;external;
  359. procedure cursorup;external;
  360. procedure dsp;external;
  361. procedure dspat;external;
  362. procedure dspcolour;external;
  363. procedure dspend;external;
  364. procedure dspjust;external;
  365. procedure dspln;external;
  366. procedure dsplncolour;external;
  367. procedure dsppart;external;
  368. procedure dspvert;external;
  369. procedure foreground;external;
  370. procedure formatleft;external;
  371. procedure formatright;external;
  372. function  getcolour;external;
  373. function  getpage;external;
  374. procedure intenseoff;external;
  375. procedure intenseon;external;
  376. procedure normal;external;
  377. procedure reverse;external;
  378. procedure rowcolour;external;
  379. procedure screencolour;external;
  380. procedure setcolour;external;
  381. procedure setpage;external;
  382.  
  383. {$L TPFSTR.OBJ}
  384. procedure changechar;external;
  385. function  compare;external;
  386. procedure deletechar;external;
  387. procedure deleteleft;external;
  388. procedure deleteright;external;
  389. function  leftend;external;
  390. procedure lowercase;external;
  391. procedure overwrite;external;
  392. procedure padcentre;external;
  393. procedure padends;external;
  394. procedure padleft;external;
  395. procedure padright;external;
  396. procedure replace;external;
  397. function  rightend;external;
  398. function  seekstring;external;
  399. function  stringend;external;
  400. function  stringof;external;
  401. procedure uppercase;external;
  402. function  wordcount;external;
  403.  
  404. {$F-}   { restore  call linking }
  405.  
  406. { ------------------------------------------------------------------------- }
  407. procedure dspc (strx : stype ;y,colour :byte);
  408.  
  409.   begin
  410.         dspat(strx,40 - length(strx) div 2,y,colour);
  411.   end;
  412.  
  413. { ------------------------------------------------------------------------- }
  414. function whatcard : cardtype;
  415.  
  416.  
  417. var
  418.   code  :byte;
  419.   regs : registers;
  420.  
  421. begin
  422.   regs.ah := $1A;             { attempt to call vga identify card function }
  423.   regs.al := $00;             { must clear al to 0 ...                     }
  424.   intr($10,regs);
  425.   if regs.al = $1A then       { so that if $1a comes back in al...         }
  426.     begin                     { we know a ps/2 video bios is out there.    }
  427.       case regs.bl of         { code comes back in bl.                     }
  428.         $00 : whatcard := none;
  429.         $01 : whatcard := mda;
  430.         $02 : whatcard := cga;
  431.         $04 : whatcard := egacolour;
  432.         $05 : whatcard := egamono;
  433.         $07 : whatcard := vgamono;
  434.         $08 : whatcard := vgacolour;
  435.         $0a,$0c : whatcard := mcgacolour;
  436.         $0b : whatcard := mcgamono;
  437.         else whatcard := cga
  438.       end { case }
  439.     end
  440.   else
  441.                                   { if it's not ps/2 we have to check for  }
  442.      begin                        { the presence of an ega bios:           }
  443.       regs.ah := $12;             { select alternate function service      }
  444.       regs.bx := $10;             { bl=$10 means return ega information    }
  445.       intr($10,regs);             { do it                                  }
  446.       if regs.bx <> $10 then      { bx unchanged means ega is not there... }
  447.         begin
  448.           regs.ah := $12;         { once we know alt function exists...    }
  449.           regs.bl := $10;         { ...we call it again to see if it's...  }
  450.           intr($10,regs);         { ...ega colour or ega monochrome.       }
  451.           if (regs.bh = 0) then whatcard := egacolour
  452.             else whatcard := egamono
  453.         end
  454.       else
  455.                                   { now we know its a cga or mda  bastard !}
  456.         begin
  457.           intr($11,regs);         { $11 = equipment determination service  }
  458.           code := (regs.al and $30) shr 4;
  459.           case code of
  460.             1 : whatcard := cga;
  461.             2 : whatcard := cga;
  462.             3 : whatcard := mda
  463.             else whatcard := none
  464.           end { case }
  465.         end
  466.     end;
  467. end;
  468.  
  469. { ------------------------------------------------------------------------- }
  470. {                          unit initialisation                              }
  471. { ------------------------------------------------------------------------- }
  472.  
  473. begin
  474.   case whatcard of
  475.     cga,
  476.     mcgacolour,
  477.     egacolour,
  478.     vgacolour :  video_buff := $b800;
  479.     mda,
  480.     mcgamono,
  481.     egamono,
  482.     vgamono  :   video_buff := $b000;
  483.   end;  { case }
  484.   snow_check   := false; { set to true fro snow prone monitors }
  485.   video_page   := 0;     { default video page, 0-7 for EGA/VGA }
  486.   startline    := 11;  { normal cursor }
  487.   stopline     := 12;  { normal cursor }
  488. end.
  489.  
  490.