home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
progm
/
tpfast.zip
/
TPFAST.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-09-26
|
16KB
|
403 lines
{ _______________________________________________________________
| |
| Copyright (C) 1989,1990 Steven Lutrov |
|_______________________________________________________________|____
| | |
| Program Title : Tpfast.Pas | | ___
| Author : Steven Lutrov | | |
| Revision : 3.00 | | |
| Date : 1990-07-16 | | |
| Language : Turbo Pascal 5.5 | | |
| | | |
| Description : Unit File For All The Assembly Routines | | |
| : Fastscr.Asm Faststr.Asm Fastfile.Asm | | |
| : Fastgrp.Asm Fastbit.Asm Fastkbd.Asm | | |
| | | |
|_______________________________________________________________| | |
| | |
|________________________________________________________________| |
| |
|_________________________________________________________________|
}
Unit Tpfast;
{ ------------------------------------------------------------------------- }
Interface
{ ------------------------------------------------------------------------- }
Uses Dos,Crt;
{ ------------------------------------------------------------------------- }
Type
{ ------------------------------------------------------------------------- }
Stype = String[80]; { Used For 1 screen line Etc }
Cardtype = (None,Mda,Cga,Egamono,EgaColour,Vgamono,
VgaColour,Mcgamono,McgaColour);
{ ------------------------------------------------------------------------- }
Var
{ ------------------------------------------------------------------------- }
Errreturn : Byte; { Global Error Monitor }
Video_Buff : Word; { Address Of Video Buffer }
Snow_Check : Boolean; { Check For Snow On Screen Writes }
Video_Page : Byte; { Video Page Used For Screen Writes }
Textattr : Byte; { The Text Attribute Byte Setting }
Startline : Byte;
Stopline : Byte;
Textbufbase : Pointer; { Pointer to Base address of video screen }
{ ------------------------------------------------------------------------- }
Function Bytetohex(Work_: Byte): Stype;
Function Rotatewordleft(Work_: Word; Bits_: Byte): Word;
Function Rotatebyteright(Work_,Bits_: Byte): Byte;
Function Rotatebyteleft(Work_,Bits_:Byte): Byte;
Function Rotatewordright(Work_: Word; Bits_: Byte): Word;
Function Wordtohex(Work_: Word): Stype;
Function Closefile(Handle:Integer):Boolean;
Function Createfile(Fname:String; Attribute:Integer):Integer;
Function Erasefile(Name:String):Integer;
Function Fmovepointer(Handle,Mode:Integer;Offset:Longint;Var Location: Longint):Boolean;
Function Getverify: Boolean;
Function Getvolume(Disk: Integer; Workarea: Pointer): Stype;
Function Openfile(Name:String; Access:Integer):Integer;
Function Readfile(Handle:Word; Amount:Word; Var Buff):Integer;
Procedure Readsector(Segment,Offset,Drive,Sector,Number: Word);
Procedure Setverify(Setting: Boolean);
Procedure Setvolume(Disk: Integer; Newlabel: Stype; Workarea: Pointer);
Function Writefile(Handle:Integer; Nwrite:Word; Var Buff):Integer;
Procedure Writesector(Segment,Offset,Drive,Sector,Number: Word);
Procedure Clearpage(Pagenumber,Colour: Byte);
Procedure Copyclear(Box: Pointer; X_Pos,Y_Pos,X_Num,Y_Num,Colour: Byte);
Procedure Drawbox(Char_X ,Char_Y :Char;X_Pos,Y_Pos,X_Num,Y_Num,Colour:Byte);
Procedure Fillscreen(Ch: Char; X_Pos,Y_Pos,X_Num,Y_Num,Colour: Byte);
Procedure Restorescreen(Box: Pointer; X_Pos,Y_Pos,X_Num,Y_Num: Byte);
Procedure Savescreen(Box: Pointer; X_Pos,Y_Pos,X_Num,Y_Num: Byte);
Procedure Screendown(Box: Pointer; Var X_Pos,Y_Pos: Byte; X_Num,Y_Num: Byte);
Procedure Screenleft(Box:Pointer; Var X_Pos,Y_Pos: Byte; X_Num,Y_Num: Byte);
Procedure Screenright(Box:Pointer; Var X_Pos,Y_Pos: Byte; X_Num,Y_Num: Byte);
Procedure Screenup(Box: Pointer; Var X_Pos,Y_Pos: Byte; X_Num,Y_Num: Byte);
Procedure Scrollx(Where: Char; X_Pos,Y_Pos,X_Num,Y_Num,Cols,Colour: Byte);
Procedure Scrolly(Where: Char; X_Pos,Y_Pos,X_Num,Y_Num,Lines,Colour: Byte);
Procedure Swappage(Box: Pointer; Pagenumber: Byte);
Function Altkeydown: Boolean;
Function Capslockdown: Boolean;
Function Capslockon: Boolean;
Procedure Clearbuffer;
Procedure Clearcapslock;
Procedure Clearins;
Procedure Clearnumlock;
Procedure Clearscrolllock;
Function Ctrlkeydown: Boolean;
Function Freshchar: Char;
Function Getscan: Byte;
Function Inskeydown: Boolean;
Function Inskeyon: Boolean;
Procedure Keypause(Code: Char; Ascii: Boolean; Wait_A,Wait_B: Byte);
Function Lastkey: Char;
Function Leftshiftdown: Boolean;
Function Nextkey: Char;
Function Numlockdown: Boolean;
Function Numlockon: Boolean;
Function Readchar: Char;
Function Rightshiftdown: Boolean;
Function Scrolllockdown: Boolean;
Function Scrolllockon: Boolean;
Procedure Setcapslock;
Procedure Setins;
Procedure Setnumlock;
Procedure Setscrolllock;
Procedure Background(Code: Char);
Procedure Blinkoff;
Procedure Blinkon;
Procedure Colourx(X_Pos,Y_Pos,Y_Pos,Colour: Byte);
Procedure Cursordown(Y_Pos: Integer);
Procedure Cursorleft(Columns: Integer);
Procedure Cursoroff;
Procedure Cursoron;
Procedure Cursorright(Columns: Integer);
Procedure Cursorup(Y_Pos: Integer);
Procedure Dsp(Strx: Stype);
Procedure Dspat(Strx: Stype; X_Pos,Y_Pos,Colour: Byte);
Procedure Dspcolour(Strx: Stype; Colour: Byte);
Procedure Dspend(Strx: Stype; X_Pos,Y_Pos,Length,Colour: Byte);
Procedure Dspjust(Strx: Stype; X_Pos,Y_Pos,Colour: Byte);
Procedure Dspln(Strx: Stype);
Procedure Dsplncolour(Strx: Stype; Colour: Byte);
Procedure Dsppart(Strx: Stype; Start,Numch,X_Pos,Y_Pos,Colour: Byte);
Procedure Dspvert(Strx: Stype; X_Pos,Y_Pos,Colour: Byte);
Procedure Foreground(Code: Char);
Procedure Formatleft(Strx: Stype; How_Many: Integer; Colour: Byte);
Procedure Formatright(Strx: Stype; How_Many: Integer; Colour: Byte);
Function Getcolour(X_Pos,Y_Pos: Byte): Byte;
Function Getpage: Integer;
Procedure Intenseoff;
Procedure Intenseon;
Procedure Normal;
Procedure Reverse;
Procedure Rowcolour(X_Pos,Y_Pos,X_Num,Colour: Byte);
Procedure Screencolour(X_Pos,Y_Pos,X_Num,Y_Pos,Colour: Byte);
Procedure Setcolour(X_Pos,Y_Pos,Colour: Byte);
Procedure Setpage(Pagenumber: Integer);
Procedure Changechar(Var Strx: Stype; Search,Replace: Char);
Function Compare(Strg1,Strg2: Stype): Boolean;
Procedure Deletechar(Var Strx: Stype; Ch: Char);
Procedure Deleteleft(Var Strx: Stype; Border: Char);
Procedure Deleteright(Var Strx: Stype; Border: Char);
Function Leftend(Var Strx: Stype; Border: Char): Stype;
Procedure Lowercase(Var Strx: Stype);
Procedure Overwrite(Var Strx: Stype; Substrg: Stype; Position: Integer);
Procedure Padcentre(Var Strx: Stype; Ch: Char; Position,Length: Integer);
Procedure Padends(Var Strx: Stype; Ch: Char; Length: Integer);
Procedure Padleft(Var Strx: Stype; Ch: Char; Length: Integer);
Procedure Padright(Var Strx: Stype; Ch: Char; Length: Integer);
Procedure Replace(Var Strx: Stype; Substrg: Stype; Position,Chars: Integer);
Function Rightend(Var Strx: Stype; Border: Char): Stype;
Function Seekstring(Strx,Substrg: Stype; Startpt: Integer):Integer;
Function Stringend(Strx: Stype; Numberchars: Integer): Stype;
Function Stringof(Substrg: Stype; Length: Integer): Stype;
Procedure Uppercase(Var Strx: Stype);
Function Wordcount(Strx: Stype): Integer;
{ Routines That Are Partially Assembly Written }
Procedure Dspc(Strx : Stype ;Y_Pos,Colour:Byte);
{ ------------------------------------------------------------------------- }
Implementation
{ ------------------------------------------------------------------------- }
{$F+} { Force Far Call Linking }
{$L FastBit.Obj}
Function Bytetohex;External;
Function Rotatewordleft;External;
Function Rotatebyteright;External;
Function Rotatebyteleft;External;
Function Rotatewordright;External;
Function Wordtohex;External;
{$L FastFile.Obj}
Function Closefile;External;
Function Createfile;External;
Function Erasefile;External;
Function Fmovepointer;External;
Function Getverify;External;
Function Getvolume;External;
Function Openfile;External;
Function Readfile;External;
Procedure Readsector;External;
Procedure Setverify;External;
Procedure Setvolume;External;
Function Writefile;External;
Procedure Writesector;External;
{$L FastGrp.Obj}
Procedure Clearpage;External;
Procedure Copyclear;External;
Procedure Drawbox;External;
Procedure Fillscreen;External;
Procedure Restorescreen;External;
Procedure Savescreen;External;
Procedure Screendown;External;
Procedure Screenleft;External;
Procedure Screenright;External;
Procedure Screenup;External;
Procedure Scrollx;External;
Procedure Scrolly;External;
Procedure Swappage;External;
{$L FastKbd.Obj}
Function Altkeydown;External;
Function Capslockdown;External;
Function Capslockon;External;
Procedure Clearbuffer;External;
Procedure Clearcapslock;External;
Procedure Clearins;External;
Procedure Clearnumlock;External;
Procedure Clearscrolllock;External;
Function Ctrlkeydown;External;
Function Freshchar;External;
Function Getscan;External;
Function Inskeydown;External;
Function Inskeyon;External;
Procedure Keypause;External;
Function Lastkey;External;
Function Leftshiftdown;External;
Function Nextkey;External;
Function Numlockdown;External;
Function Numlockon;External;
Function Readchar;External;
Function Rightshiftdown;External;
Function Scrolllockdown;External;
Function Scrolllockon;External;
Procedure Setcapslock;External;
Procedure Setins;External;
Procedure Setnumlock;External;
Procedure Setscrolllock;External;
{$L FastScr.Obj}
Procedure Background;External;
Procedure Blinkoff;External;
Procedure Blinkon;External;
Procedure Colourx;External;
Procedure Cursordown;External;
Procedure Cursorleft;External;
Procedure Cursoroff;External;
Procedure Cursoron;External;
Procedure Cursorright;External;
Procedure Cursorup;External;
Procedure Dsp;External;
Procedure Dspat;External;
Procedure Dspcolour;External;
Procedure Dspend;External;
Procedure Dspjust;External;
Procedure Dspln;External;
Procedure Dsplncolour;External;
Procedure Dsppart;External;
Procedure Dspvert;External;
Procedure Foreground;External;
Procedure Formatleft;External;
Procedure Formatright;External;
Function Getcolour;External;
Function Getpage;External;
Procedure Intenseoff;External;
Procedure Intenseon;External;
Procedure Normal;External;
Procedure Reverse;External;
Procedure Rowcolour;External;
Procedure Screencolour;External;
Procedure Setcolour;External;
Procedure Setpage;External;
{$L FastStr.Obj}
Procedure Changechar;External;
Function Compare;External;
Procedure Deletechar;External;
Procedure Deleteleft;External;
Procedure Deleteright;External;
Function Leftend;External;
Procedure Lowercase;External;
Procedure Overwrite;External;
Procedure Padcentre;External;
Procedure Padends;External;
Procedure Padleft;External;
Procedure Padright;External;
Procedure Replace;External;
Function Rightend;External;
Function Seekstring;External;
Function Stringend;External;
Function Stringof;External;
Procedure Uppercase;External;
Function Wordcount;External;
{$F-} { Restore Call Linking }
{ ------------------------------------------------------------------------- }
Procedure Dspc (Strx : Stype ;Y_Pos,Colour:Byte);
Begin
Dspat(Strx,40 - Length(Strx) Div 2,Y_Pos,Colour);
End;
{ ------------------------------------------------------------------------- }
Function WhatCard : Cardtype;
Var
Code : Byte;
Regs : Registers;
Begin
Regs.Ah := $1A; { Attempt To Call Vga Identify Card Function }
Regs.Al := $00; { Must Clear Al To 0 ... }
Intr($10,Regs);
If Regs.Al = $1A Then { So That If $1A Comes Back In Al... }
Begin { We Know A Ps/2 Video Bios Is Out There. }
Case Regs.Bl Of { Code Comes Back In Bl. }
$00 : WhatCard := None;
$01 : WhatCard := Mda;
$02 : WhatCard := Cga;
$04 : WhatCard := EgaColour;
$05 : WhatCard := Egamono;
$07 : WhatCard := Vgamono;
$08 : WhatCard := VgaColour;
$0A,$0C : WhatCard := McgaColour;
$0B : WhatCard := Mcgamono;
Else WhatCard := Cga
End { Case }
End
Else
{ If It'S Not Ps/2 We Have To Check For }
Begin { The Presence Of An Ega Bios: }
Regs.Ah := $12; { Select Alternate Function Service }
Regs.Bx := $10; { Bl=$10 Means Return Ega Information }
Intr($10,Regs); { Do It }
If Regs.Bx <> $10 Then { Bx Unchanged Means Ega Is Not There... }
Begin
Regs.Ah := $12; { Once We Know Alt Function Exists... }
Regs.Bl := $10; { ...We Call It Again To See If It'S... }
Intr($10,Regs); { ...Ega Colour Or Ega Monochrome. }
If (Regs.Bh = 0) Then WhatCard := EgaColour
Else WhatCard := Egamono
End
Else
{ Now We Know its a Cga Or Mda Bastard !}
Begin
Intr($11,Regs); { $11 = Equipment Determination Service }
Code := (Regs.Al And $30) Shr 4;
Case Code Of
1 : WhatCard := Cga;
2 : WhatCard := Cga;
3 : WhatCard := Mda
Else WhatCard := None
End { Case }
End
End;
End;
{ ------------------------------------------------------------------------- }
Function Gettextbuforigin : Word;
{ Jeff Duntemans rule from Doctor Dobbs Journal : }
{ For Boards Attached To Monochrome Monitors, The Buffer }
{ Origin Is $B000:0; For Boards Attached To Colour Monitors (Including }
{ All Composite Monitors And Tv'S) The Buffer Origin Is $B800:0. }
Begin
Case WhatCard Of
Cga,
McgaColour,
EgaColour,
VgaColour : GetTextbuforigin := $B800;
Mda,
Mcgamono,
Egamono,
Vgamono : Gettextbuforigin := $B000;
End { Case }
End;
{ ------------------------------------------------------------------------- }
{ Unit Initialisation }
{ ------------------------------------------------------------------------- }
Begin
Video_Buff := Gettextbuforigin; { Base address }
Snow_Check := True; { Change as you wish ! }
Video_Page := 0; { Initialy Video Page Should 0 }
End.