Unit Extense;
{$G+}
Interface
Type PalType = Array[0..255,1..3] of Byte;
MStr = String[80];
Var
Pall : PalType;
{ Screen : Array[0..$b800] of byte absolute $b800:0000;
{-- Video Functions --}
Function VGA_Card : Boolean;
Function IsVesa : Boolean;
Function VidMode : Byte;
function VidSeg: Word;
Procedure Reset_Video;
Procedure Change_28;
Procedure Change_30;
Procedure WaitRetrace;
procedure FillWord(var x; count:integer; w:word);
Procedure VGA_SetBlink(BlinkMode : Boolean);
Procedure VGA_SetFontSize(FontSize:Byte);
Procedure VGA_SetPallette(ColorNo : Byte; R,G,B : Byte);
Procedure VGA_GrabPallette;
Procedure VGA_GetPallette(Col : Byte; Var R,G,B : Byte);
Procedure VGA_FadeUp;
Procedure VGA_FadeDown;
Procedure VGA_GreyScale;
Procedure VGA_RestorePallette;
Procedure VGA_Blinking(State : Boolean);
Procedure VGA_Set8x16Font;
Procedure Color (F,B : BYTE);
Procedure ClearLine(Line : Byte;CharsPerRow : Byte);
Procedure GoXy(x,y : Word);
Procedure Setcursorshape(shape : word);
Procedure qwrite(x,y:byte;s:string;f,b:byte;CharsperRow:Word);
Procedure Uncrunch(var Addr1,Addr2; BlkLen:Integer);
Procedure Putpixel(X,Y : Word;Color : Byte);
Procedure SetScreenStart(ScanLine:word);
Procedure Yescursor;
Procedure Nocursor;
{-- Keyboard Functions --}
Procedure SetTypeRate(Kdelay, Krate:Byte);
Function ShiftState : Byte;
Function ScrollLock : Boolean;
Function CapsLock : Boolean;
Function InsKey : Boolean;
Function AltKey : Boolean;
Procedure Clear_Keyboard_Buffer;
Function Yesno(unlit,lit : Byte) : Boolean;
Procedure InputPhone(var Lne : String);
Procedure InputNums(var Lne:String;Chars:Byte;AllowZero:Boolean);
Procedure InputLn(var Lne:String;Chars:Byte;Caps:Boolean;Allcaps:Boolean);
Procedure InputRelaxed(var Lne:String;Chars:Byte;Caps:Boolean;Allcaps:Boolean);
Procedure GetKeys(Var C1 : Char;Var C2 : Char);
Function Get_Extended_KeyCode : Word;
{-- String Functions --}
Function Digit(k:char):boolean;
Function Comma(I : LongInt): String;
Function Uppercase(Str : String) : String;
Function Strr(I : LongInt) : String;
Function Center(Str : String) : Byte;
Function Padcenter(Str : String;Amount : Byte) : String;
Function Padstring(Outp : String;Number : Byte): String;
Function LeadingZero(w : Word) : String;
Function ASCIZToString (ASCIZ: array of Char): String;
Function StrJust(S : String; Size : Byte) : String;
function Real2String (r:real):mstr;
function Str2Byte(q:mstr):integer;
Function Hex(Value:byte):string;
FUNCTION HexToLong(S : STRING) : LONGINT;
{-- Memory Handling --}
Procedure FastMove(VAR source;VAR dest;numToMove : WORD);
Procedure MovW(var source,dest; num: word);
Procedure Cold_Boot;
Procedure Warm_Boot;
{-- Bitwise Opperations --}
Function GetBitA(var a;Bit:Word):Boolean;
Procedure InvertBitA(var a;Bit:Word);
{-- Misc. Schtuff --}
Procedure Draw_Dialog(X,Y,Height : Byte);
function PrinterReady(PN: word): boolean;
Procedure Clear_Column(Column : Byte);
Procedure Beep(Freq,Dely : Word);
Procedure PipeWrite(S : String);
procedure mousesensetivity(x,y:word);
Procedure FadeWrite(Strng : String);
Procedure Toggle(Var Bln : Boolean);
Procedure SDelay(S : Word);
Procedure SetTurbo(Turbo : Boolean);
Procedure PrintScreen(On : Boolean);
Function SoundBlaster : Boolean;
function valu (q:String):integer;
FUNCTION HexWord(a : Word) : String;
{-- Clearing Functions --}
Procedure Woop_dat_screen;
Procedure PulltheBars;
Procedure RollUp;
Procedure Column_Clear;
Procedure Row_Clear;
Procedure Close_Horizontal;
Procedure Close_Vertical;
Procedure SlideUp;
Procedure SlideDown;
Procedure SlideLeft;
Procedure SlideRight;
Procedure Squish_Screen;
{-- File Handling --}
Function FileExist(FileName : String) : Boolean;
Procedure DeleteFile(FileName : string);
Function Is_Directory(StDir : String): Boolean;
Function DirExist(StDir : String): Boolean;
Function Is_Floppy(D: Byte) : Boolean;
Function Is_CDRom(Drv : Char) : Boolean;
Function Get_Prg_Dir : string;
Implementation
Uses Dos,Crt,Strings;
Var Kb : Byte Absolute $0040:$0017;
FUNCTION HexWord(a : Word) : String;
CONST Digit : ARRAY[$0..$F] OF Char = '0123456789ABCDEF';
VAR
I : Byte;
HexStr : String;
BEGIN
HexStr := '';
FOR I := 1 TO 4 DO
BEGIN
Insert(Digit[a AND $000F], HexStr, 1);
a := a SHR 4
END;
HexWord := HexStr;
END; {hex}
function valu (q:string):integer;
var i,s,pu:integer;
r:real;
begin
While Q[Byte(Q[0])]=#32 Do Q[Byte(Q[0])]:=Pred(Q[Byte(Q[0])]);
valu:=0;
if byte(q[0])=0 then exit;
if not (q[1] in ['0'..'9','-']) then exit;
if byte(q[0])>5 then exit;
val (q,r,s);
if s<>0 then exit;
if (r<=32767.0) and (r>=-32767.0)
then valu:=round(r)
end;
Function Get_Cur_Dir : String;
Var Temp : String;
Begin
GetDir(0,Temp);
Get_Cur_Dir := Temp;
End;
Function Get_Prg_Dir : string;
var Tmp : string;
Begin
Tmp := ParamStr(0);
while (Tmp[Length(Tmp)] <> '\') and (Length(Tmp) <> 0) do Delete(Tmp,Length(Tmp),1);
if Tmp = '' then Tmp := Get_Cur_Dir;
Get_Prg_Dir := Tmp;
End;
Procedure Change_30;
Const Regvalues : Array[1..8] of Word =
($0c11,$0d06,$3e07,$ea10,$8c11,$df12,$e715,$0616);
Var
X,I,Data : Byte;
Offset : Word;
Begin
MemW[$0040:$004c]:= 8192;
Mem[$0040:$0084] := 29;
Offset := MemW[$0040:$0063];
Asm cli End;
For I := 1 to 8 do PortW[Offset]:=Regvalues[i];
Data := Port[$03cc];
Data := Data And $33;
Data := Data Or $C4;
Port[$03c2] := Data;
Asm
sti
mov ah,12h
mov bl,20h
int 10h
End;
End;
Procedure Change_28;Assembler;
Asm
mov ax,1202h
mov bl,30h
int 10h
mov ax,0003h
Int 10h
mov ax,1111h
mov bl,00h
int 10h
end;
Function Digit(k:char):boolean;
Begin
Digit := Ord(k) in [48..57]
End;
Procedure Color (F,B : BYTE); Assembler;
ASM
MOV AL, B
SHL AL, 4
OR AL, F
MOV TextAttr, AL
END;
Function ASCIZToString (ASCIZ: array of Char): String;
Begin
ASCIZToString := StrPas(@ASCIZ);
End;
Procedure VGA_GrabPallette;
Var X : Integer;
Begin
For X := 0 to 255 do VGA_Getpallette(X,pall[X,1],pall[X,2],pall[X,3]);
End;
Function SoundBlaster : Boolean;
Const NrTimes = 10;
NrTimes2 = 50;
Var Found : Boolean;
Counter1,Counter2 : Word;
SBPort : Word;
Begin
SBPort := $210;
Found := False;
Counter1:= NrTimes;
While (SBPort<=$260) And Not Found Do
Begin
Port[SBPort+6] := 1;
Port[SBPort+6] := 0;
Counter2 := NrTimes2;
While (Counter2>0) And (Port[SBPort+$E]<128) Do Dec(Counter2);
If (Counter2=0) Or (Port[SBPort+$A]<>$AA) Then
Begin
Dec(Counter1);
If (Counter1=0) Then
Begin
Counter1:=NrTimes;
SBPort:=SBPort+$10;
End
End Else Found := True;
End;
SoundBlaster := Found;
End;
Procedure SDelay(S : Word);
Var X : Word;
SX,SY : Byte;
Begin
For X := 1 to S do
Begin
Delay(1);
If Keypressed then Exit;
End;
End;
Function ShiftState: Byte;
Var Regs: Registers;
Begin
Regs.Ah:=2;
Intr($16, Regs);
ShiftState:=Regs.Al;
End;
Procedure VGA_GetPallette(Col : Byte; Var R,G,B : Byte);
Var rr,gg,bb : Byte;
Begin
asm
mov dx,3c7h
mov al,col
out dx,al
add dx,2
in al,dx
mov [rr],al
in al,dx
mov [gg],al
in al,dx
mov [bb],al
end;
r := rr;g := gg;b := bb;
end;
function VidSeg: Word;
var
VidM: ^Byte;
begin
{$iFDEF VER70}
VidM := Ptr(Seg0040,$0049);
if VidM^ = 7 then VidSeg := SegB000 else VidSeg := SegB800;
{$ELSE}
VidM := Ptr($0040,$0049);
if VidM^ = 7 then VidSeg := $B000 else VidSeg := $B800;
{$ENDiF}
end;
Procedure Clear_Keyboard_Buffer;
Begin
MemW[$0000:$041C] := MemW[$0000:$041A];
End;
Procedure VGA_SetPallette(ColorNo : Byte; R,G,B : Byte);Assembler;
asm
mov dx,$3c8
xor ax,ax
mov al,ColorNo;out dx,al
mov dx,$3c9
mov al,r;out dx,al
mov al,g;out dx,al
mov al,b;out dx,al
end;
Procedure VGA_GreyScale;
Var X : Byte;
RedReal,GreenReal,BlueReal : Real;
R,G,B : Byte;
Grey : Integer;
Begin
For X := 0 to 255 do
Begin
VGA_GetPallette(X,R,G,B);
RedReal := R;
GreenReal := G;
BlueReal := B;
Grey := Round((RedReal * 0.30)+(GreenReal * 0.59)+(BlueReal * 0.11));
VGA_SetPallette(X,Grey,Grey,Grey);
End;
End;
Procedure VGA_RestorePallette;
Var loop1 : Integer;
Begin
For loop1 := 0 to 255 do VGA_setpallette(loop1,Pall[loop1,1],Pall[loop1,2],Pall[loop1,3]);
End;
Procedure VGA_Fadeup;
Var loop1,loop2 : Byte;
Tmp : Array [1..3] of Byte;
Begin
For loop1:=1 to 64 do BEGIN
WaitRetrace;
For loop2:=0 to 255 do BEGIN
VGA_Getpallette(loop2,Tmp[1],Tmp[2],Tmp[3]);
If Tmp[1]<Pall[loop2,1] then inc(Tmp[1]);
If Tmp[2]<Pall[loop2,2] then inc(Tmp[2]);
If Tmp[3]<Pall[loop2,3] then inc(Tmp[3]);
VGA_SetPallette (loop2,Tmp[1],Tmp[2],Tmp[3]);
End;
End;
End;
Procedure VGA_FadeDown;
VAR loop1,loop2:integer;
Tmp : Array [1..3] of byte;
BEGIN
For loop1:=1 to 64 do BEGIN
For loop2:=0 to 255 do BEGIN
VGA_Getpallette (loop2,Tmp[1],Tmp[2],Tmp[3]);
If Tmp[1]>0 then dec(Tmp[1]);
If Tmp[2]>0 then dec(Tmp[2]);
If Tmp[3]>0 then dec(Tmp[3]);
VGA_SetPallette (loop2,Tmp[1],Tmp[2],Tmp[3]);
END;
END;
END;
Function Comma(I : LongInt): String;
Var S : String[80];
X : Integer;
Begin
Str(i:0,s);
x := Length(s)-2;
While x > 1 do Begin
Insert(',',s,x);
Dec(x,3);
End;
Comma := s;
End;
PROCEDURE VGA_SetFontSize (FontSize:Byte); ASSEMBLER;
ASM
MOV DX,$03D4 { CRTC address register }
MOV AL,9 { Index for Max Scanline Register }
OUT DX,AL { set MSL as active register }
INC DX { Set DX to CRTC Data register }
IN AL,DX { read current MSL }
AND AL,011100000b { set MSL to 0, preserve others bits}
MOV AH,[FontSize] { get required size }
DEC AH { minus one. }
OR AL,AH { set size in MSL field }
OUT DX,AL { Writeback modified value }
END;
Procedure NoCursor;Assembler;
asm mov ah,1; mov cx,2000h;Int 10h end; {No Cursor}
Procedure YesCursor;Assembler;
asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}
function PrinterReady(PN: word): boolean; assembler;
asm
mov dx, PN {printer number goes in DX}
mov ah, 02h
int 17h {int. 17h service 02h}
xor al, al {assume false}
and ah, 10101000b {clear all other bits}
cmp ah, 10000000b {ready & not out of paper or error?}
jne @Done {no -- leave result false}
inc ax {yes -- change to true}
@Done:
end;
Function Is_Floppy(D: Byte) : Boolean;
Var Regs: Registers;
Begin
regs.ax:= $4408;
regs.bl:= d;
Msdos(Regs);
Is_floppy := ((regs.flags and fcarry) = 0) and (regs.ax = 0);
End;
Function Is_CDRom(Drv : Char) : Boolean;
Var
Regs : Registers;
Cdr : string;
Cnt : byte;
Begin
Is_CdRom := False;
Cdr := '';
regs.ax := $1500;
regs.bx := 0;
regs.cx := 0;
Intr($2F,Regs);
If regs.bx > 0 then
For cnt := 0 to (regs.bx-1) do cdr := cdr+char(regs.cl+Byte('A')+cnt);
Is_CDRom := Pos(upcase(Drv),cdr)>0
End;
Function Hex(Value:byte):string;
Const HexTable : Array[0..15] of Char=
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
Var HexStr : String;
Begin
HexStr[2]:=HexTable[Value and $0F]; { Convert low nibble }
HexStr[1]:=HexTable[Value and $F0 div 16]; { Convert high nibble }
HexStr[0]:=#2; { Set Stringlength }
Hex := HexStr;
End;
Function VidMode : Byte;
Var
Mode : Byte;
begin
Asm
MOV AH, 0Fh { Set Function to 0Fh - Get current video mode }
INT 10h { Call interrupt 10h - Video Services }
MOV Mode, AL { Move INT 10h result to Mode Variable }
end;
VidMode := Mode;
end;
Procedure PrintScreen(On : Boolean);
Begin
If On then Mem[$0050:0000] := 1
else Mem[$0050:0000] := 0
End;
function Str2Byte(q:mstr):integer;
var i,s,pu: integer;
r : real;
begin
While Q[Byte(Q[0])]=#32 Do Q[Byte(Q[0])]:=Pred(Q[Byte(Q[0])]);
Str2Byte:=0;
if byte(q[0])=0 then exit;
if not (q[1] in ['0'..'9','-']) then exit;
if byte(q[0])>5 then exit;
val (q,r,s);
if s<>0 then exit;
if (r<=32767.0) and (r>=-32767.0)
then Str2Byte:=round(r)
end;
function Real2String (r:real):mstr;
var q:mstr;
begin
str (r:0:0,q);
Real2String := q
end;
Function StrJust(S : String; Size : Byte) : String;
Begin
While Length(S) < Size Do Insert(#32, S, 1);
StrJust := S;
End;
Procedure Toggle(Var Bln : Boolean);
Begin
Bln := Not(Bln);
End;
Procedure DeleteFile(FileName : string); Assembler;
Asm
push ds
lds si,FileName
inc byte ptr [si]
mov bl,byte ptr [si]
xor bh,bh
mov dx,si
inc dx
mov byte ptr [si+bx],0
mov ah,41h
int 21h
pop ds
End;
Procedure Warm_Boot;
Begin
Inline($BB/$00/$01/$B8/$40/$00/$8E/$D8/$89/$1E/$72/$00/$EA/$00/$00/$FF/$FF);
End;
Procedure Cold_Boot;
Begin
Inline($BB/$38/$12/$B8/$40/$00/$8E/$D8/$89/$1E/$72/$00/$EA/$00/$00/$FF/$FF);
End;
Procedure Squish_Screen;
Label Rulp;
Begin
asm { Clear the Next 4 Screens in video memory }
cld
mov ax,0b800h
mov es,ax
mov di,4000
mov cx,8000
mov ax,0720h
rep stosw
mov cx,0fh
End;
rulp:
asm
mov dx,3d4h
mov ah,cl
mov al,9
out dx,ax
end;
waitretrace;
asm
loop rulp
xor di,di
mov cx,2000
mov ax,0720h
rep stosw
mov dx,3d4h
mov ah,0fh
mov al,9
out dx,ax
end;
asm
mov ax,3; int 10h;
end;
End;
Procedure Draw_Dialog(X,Y,Height : Byte);
Var P : Byte;
Begin
Qwrite(X,Y,' ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄',8,0,80);
GotoXy(X,Y+1);PipeWrite('|08 ▄▀▀▀ |07▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄|08 ▀▀▀▄ ');
GotoXy(X,Y+2);PipeWrite('|08▐ |15▄|23 |16|07▄|08 ▌ ');
For P := 1 to Height do
Begin
GotoXy(X,Y+3+P-1);
PipeWrite('|08▐▐|15|23▒|23 ░|16|07▌|08▌ ');
End;
GotoXy(X,Y+Height+3);PipeWrite('|08▐ |08▀|08|23▄|23|15 |16|07▀|08 ▌ ');
GotoXy(X,Y+Height+4);
Pipewrite('|08 ▀▄▄▄ |07▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀|08 ▄▄▄▀ ');
Qwrite(X,Y+height+5,' ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀ ',8,0,80);
End;
Function DirExist(StDir : String): Boolean;
Var
WoFattr : Word;
FiTemp : File;
Begin
Assign(fiTemp, (stDir + '.'));
Getfattr(fiTemp, woFattr);
if (doserror <> 0) then DirExist := false
else DirExist := ((woFattr and directory) <> 0)
End;
Function Is_Directory(StDir : String): Boolean;
Var TempFile : File;
Attribute : Word;
Begin
Assign(TempFile,stDir);
GetFattr(TEmpFile,Attribute);
if (Attribute and Directory) = 0 then Is_Directory := False else Is_Directory := True;
End;
Procedure InputRelaxed(var Lne : String;Chars:Byte;Caps:Boolean;Allcaps:Boolean);
Var
StartedX,X,Y,Counter,OldAttr : Byte;
CH : Char;
P : String;
Done : boolean;
Begin
OldAttr := Textattr;
StartedX := WhereX;
P := '';
Counter := 0;
asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}
Done := False;
For X := 1 to Chars do Write(' ');GotoXy(StartedX,WhereY);
Repeat
X := WhereX;
Y := WhereY;
MemW[$0000:$041C] := MemW[$0000:$041A];
CH := Readkey;If CH = #0 then CH := Readkey;
Case CH of
#8 : If Counter > 0 then
Begin
GotoXy(X-1,Y);Write(' ');
GotoXy(X-1,Y);Delete(P,Length(P),1);
Dec(Counter);
End;
#13 : Done := True;
#27 : Begin
P := 'Aborted';
Done := True;
End;
#32..#255 : If Counter < Chars then
Begin
Inc(Counter);
If Caps then If (P[Counter-1]=#0) or (P[Counter-1]=#32) or (P[Counter-1]=',') then
CH := Upcase(CH);
If Allcaps then CH := Upcase(CH);
P := P + (CH);
Write(CH);
End;
End;
Until Done = True;
Lne := P;
GotoXy(StartedX,WhereY);
Textattr := 7;For X := 1 to Chars do Write(' ');
If Lne <> 'Aborted' then Begin
GotoXy(StartedX,WhereY);
Write(Lne);
End;
Textattr := OldAttr;
End;
Function Get_Extended_KeyCode : Word;
Var Regs : Registers;
Begin
regs.ah := $10;
intr($16, regs);
Get_Extended_KeyCode := (regs.ah shl 4) + regs.al;
End;
Procedure FadeWrite(Strng : String);
Var
StartX,StartY,X : Byte;
Begin
StartX := WhereX;
StartY := WhereY;
Strng := Strng + ' ';
For X := 1 to Length(Strng)-4 do
Begin
GotoXy(X,WhereY);
textattr := 8;
GotoXy(StartX,StartY);
Write(Copy(Strng,1,X-1));
Textattr := 8;Write(Strng[X]);
Textattr := 3;Write(Strng[X+1]);
Textattr := 11;Write(Strng[X+2]);
Delay(50);
End;
End;
procedure FillWord(var x; count:integer; w:word);
Begin
Inline($c4/$be/x/$8b/$86/w/$8b/$8e/count/$fc/$f2/$ab);
End;
Procedure SetScreenStart(ScanLine:word);
Var StartAddress: Word;
Begin
StartAddress := (ScanLine div 16)*80;
portw[$3D4] := hi(StartAddress) shl 8 + $0C; { Set start address }
portw[$3D4] := lo(StartAddress) shl 8 + $0D;
repeat until port[$3DA] and 8<>0; { wait for retrace }
portw[$3D4] := (ScanLine mod 16) shl 8 + 8; { Set start scanline }
repeat until port[$3DA] and 8=0; { wait out retrace }
End;
Function Padcenter(Str : String;Amount : Byte) : String;
Var X : Byte;
Temp : String;
Begin
Temp := Str;
For X := 1 to (Amount div 2) do Temp := ' ' + Temp;
For X := 1 to (Amount div 2) do Temp := Temp + ' ';
Padcenter := Temp;
End;
Function Strr(I : LongInt) : String;
Var Strng : String;
Begin
Str(I,Strng);
Strr := Strng;
End;
procedure GoXY(x,y : word);
begin
asm
mov ax,y
mov dh,al
dec dh
mov ax,x
mov dl,al
dec dl
mov ah,2
xor bh,bh
int 10h
end
end;
Procedure RollUp;
Var X,Y : Integer;
Begin
For X := 1 to 40 do
Begin
WaitRetrace;
For Y := 0 to 25 do
Begin
FastMove(Mem[$B800:((Y*160)+ 82)],Mem[$B800:((Y*160)+80)],80);
FastMove(Mem[$B800:((Y*160))],Mem[$B800:((Y*160)+2)],80);
Mem[$b800:(Y*160)+1] := 0;
Mem[$b800:(Y*160)+158] := 0;
End;
End;
End;
Procedure Woop_dat_screen;
Var X,Y: Byte;
Begin
For X := 1 to 80 do
Begin
WaitRetrace;
For Y := 0 to 12 do
Begin
Mem[$b800:0000+(Y*160)+158] := 0;
Mem[$b800:0000+(Y*160)+159] := 0;
Fastmove(Mem[$b800:0000+(Y*160)+2],Mem[$b800:0000+(Y*160)],160-2);
End;
For Y := 13 to 25 do
Begin
Mem[$b800:0000+(Y*160)+0] := 0;
Mem[$b800:0000+(Y*160)+1] := 0;
Fastmove(Mem[$b800:0000+(Y*160)],Mem[$b800:0000+(Y*160)+2],160-2);
End;
End;
End;
Procedure Putpixel(X,Y : Word;Color : Byte);Assembler;
Asm
MOV ax,$a000
MOV es,ax
MOV ah,byte ptr y
MOV bx,x
ADD bx,ax
SHR ax,2
ADD bx,ax
MOV al,color
MOV es:[bx],al
End;
Procedure Reset_Video;Assembler;
Asm
mov ax,3
int 10h
End;
Function FileExist(FileName : String) : Boolean; ASSEMBLER;
Asm
PUSH DS {Save DS }
LDS SI,Filename {DS:SI => Filename }
XOR BX,BX {Clear BX }
MOV BL,[SI] {BX = Length(Filename) }
INC SI {DS:SI => Filename[1] }
MOV DX,SI {DS:DX => Filename[1] }
MOV [SI+BX],BH {Append Ascii 0 to Filename }
MOV AX,4300h {Get Attribute Function Code }
INT 21h {Get File Attributes }
MOV AL,BH {Default Result = FALSE }
ADC CL,CL {Attribute * 2 + Carry Flag }
AND CL,31h {Directory or VolumeID or Failed }
JNZ @@Done {Yes - Exit }
INC AL {No - Change Result to TRUE }
@@Done:
POP DS {Restore DS }
End; {FileExists}
Function LeadingZero(W : Word) : String;
Var S : String;
Begin
Str(w:0,S);
If Length(s) = 1 then S := '0'+S;
LeadingZero := S;
End;
Function Uppercase(Str : String) : String;
Var X : Byte;
Begin
For X := 1 to Length(Str) do Str[X] := Upcase(Str[X]);
Uppercase := Str;
End;
Procedure SetTurbo(Turbo : Boolean);
Var
Regs : Registers;
OldMem : Byte;
Begin
If Turbo then Regs.AL := 78 else Regs.AL := 74;
Regs.AH := $4F;
Intr($15, Regs);
End;
Procedure ClearLine(Line : Byte;CharsPerRow : Byte);
Begin
GoXy(1,Line);
Fillword(Mem[$b800:(Line-1)*(CharsPerRow*2)],Charsperrow,$0720);
End;
Procedure Mousesensetivity(x,y:word); Assembler;
Asm mov ax,1ah; mov bx,x; mov cx,y; xor dx,dx; int 33h end;
Procedure Setcursorshape(Shape : word);Assembler;
asm mov ah,1;mov cx,shape;int 10h; end;
Procedure VGA_Set8x16Font;ASsembler;
ASM
MOV DX,003CCh { Misc output register READ port }
IN AL,DX { Read value. }
AND AL,0F3h { Bits 2 & 3 off (Clock select 0). }
MOV DX,003C2h { Misc Output Write port }
OUT DX,AL { Writeback modified value }
CLI { NO interrupts for a while }
MOV DX,03C4h { Sequencer register }
MOV AX,100h { \ Generate and hold Synchronous }
OUT DX,AX { / reset }
MOV AL,001h { Clocking mode register }
OUT DX,AL { Activate Clocking mode register }
INC DX { Data register }
IN AL,DX { Read value }
OR AL,1 { Set Bit 0 (8/9) }
OUT DX,AL { Writeback. }
DEC DX { Back to Address register }
MOV AX,300h { \ Release Reset state. (normal) }
OUT DX,AX { / }
MOV DX,03DAh { CRTC Status register }
IN AL,DX { Read CRTC Status. (This'll reset }
{ Attribute controller flip-flop) }
MOV DX,03C0h { Attribute controller }
MOV AL,13h { Horizontal Pixel Pan }
OUT DX,AL { Activate HPP }
MOV AL,0 { \ Set HPP to 0 }
OUT DX,AL { / }
MOV AL,20h
OUT DX,AL { Set PAS field (Video has access }
{ to palette) }
STI { Interrupts allowed again }
END;
Function CapsLock : Boolean;
Begin
if (Kb and $40) = $40 then Capslock := True else Capslock := False;
End;
Function ScrollLock : Boolean;
Begin
If (Kb and $10) = $10 then ScrollLock := True Else ScrollLock := False;
End;
Function Inskey : Boolean;
Begin
InsKey :=(ShiftState and 128)<>0;
End;
Function AltKey: Boolean;
Begin
AltKey := (ShiftState and 8)<>0;
End;
Procedure SetTypeRate(Kdelay, Krate:Byte);Assembler;
asm
Mov AX,$0305;
Mov BH, Kdelay;
Mov BL, Krate;
Int $16;
End;
Procedure VGA_Blinking(State : Boolean);Assembler;
Asm
MOV AX,1003h
MOV BH,0
MOV BL,State
INT 10h
End;
Procedure GetKeys(Var C1 : Char;Var C2 : Char);
Begin
C1 := #0;C2 := #0;
C1 := Readkey;If C1 = #0 then C2 := Readkey;
End;
Function Padstring(Outp : String;Number : Byte): String;
Var X : Byte;
Begin
For X := 1 to (Number - Length(Outp)) do Outp := Outp + ' ';
Padstring := Outp;
End;
FUNCTION VGA_Card : BOOLEAN; ASSEMBLER;
ASM
MOV AX,01A00h { ┬> Display Combination Code }
INT 10h { ┘ }
CMP AL,01Ah { Is AL=01Ah then it's a VGA }
MOV AL,TRUE { Assume it'll be true }
JE @Return { We were right, quit now }
MOV AL,FALSE { We were wrong, return false }
@Return:
END;
PROCEDURE VGA_SetBlink (BlinkMode : BOOLEAN); ASSEMBLER;
ASM
MOV DX,$03DA { CRTC Status register }
IN AL,DX { Read CRTC Status. (This'll reset }
{ Attribute controller flip-flop) }
{ Set blink bit }
MOV DX,$03C0 { Attribute controller (Write port)}
MOV AL,10h+20h { Register 10h (Mode control) }
{ leave PAS field enabled. }
OUT DX,AL { Activate register 10h }
MOV DX,$03C1 { DX=003C1h (Attribute READ port) }
IN AL,DX { Read Mode control register }
MOV DX,$03C0 { DX=003C0h (Attribute Write port) }
CMP [BlinkMode],TRUE { BlinkMode = TRUE ? }
JE @SetBlinkBit { Yes jump to SetBlinkBit }
@BlinkOff: AND AL,NOT 008h { Clear the Blink bit }
JMP @SetBlinkBit { And go tell the VGA card }
@BlinkOn: OR AL,008h { Clear the Blink bit }
@SetBlinkBit:
OUT DX,AL { Rewrite Mode control register }
END;
Procedure InputNums(var Lne : String;Chars : Byte;AllowZero : Boolean);
Var StartedX,X,Y,Counter : Byte;
CH : Char;
P : String;
Done : Boolean;
Lower : Byte;
Begin
asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}
P := '';
Counter := 0;
StartedX := WhereX;
For X := 1 to Chars do Write(' ');
GotoXy(StartedX,WhereY);
Done := False;
Repeat
X := WhereX;
Y := WhereY;
MemW[$0000:$041C] := MemW[$0000:$041A];
CH := Readkey;
If Allowzero then Lower := 48 else Lower := 49;
If CH = #8 then If Counter > 0 then
Begin
GotoXy(X-1,Y);Write(' ');
GotoXy(X-1,Y);Delete(P,Length(P),1);
Dec(Counter);
End;
If CH = #13 then Done := True;
If CH = #27 then
Begin
P := 'Aborted';
Done := True;
End;
If Counter < Chars then
If (Ord(CH) < 58) and (Ord(CH) > Lower-1) then
Begin
Inc(Counter);
P := P+(CH);
Write(CH);
End;
Until (Done = True);
Lne := P;
GotoXy(StartedX,WhereY);
For X := 1 to Chars do Write(' ');
If Lne <> 'Aborted' then
Begin
GotoXy(StartedX,WhereY);
Write(Lne);
End;
End;
Procedure InputPhone(var Lne : String);
Var StartedX,X,Y,Counter : Byte;
C1,C2 : Char;
P : String[12];
Done : Boolean;
Begin
asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}
P := '';
StartedX := WhereX;
For X := 1 to 12 do Write(' ');
GotoXy(StartedX,WhereY);
Done := False;
Repeat
Qwrite(StartedX,WhereY,Padstring(P,12),0,7,80);
Counter := Length(P);
GotoXy(StartedX+Counter,WhereY);
MemW[$0000:$041C] := MemW[$0000:$041A];
C1 := #0;C2 := #0;
C1 := Readkey;If C1 = #0 then C2 := Readkey;
Case C1 of
#8 : Begin
If Counter > 0 then Delete(P,Length(P),1);
If Counter in [4,8] then Delete(P,Length(P),1);
End;
#13: Done := True;
#27: P := 'Aborted';
#48..#57 : Begin
If Counter < 12 then P := P + C1;
If Counter in [2,6] then P := P + '-';
End;
End;
Until (Done = True) or (P = 'Aborted');
Lne := P;
If Lne <> 'Aborted' then
Begin
GotoXy(StartedX,WhereY);
Write(Lne);
End;
End;
Procedure PipeWrite(S : String);
Var X,Code : Byte;
Error : Integer;
Begin
For X := 1 to Length(S) do
Begin
If S[X] <> '|' then Write(S[X])
Else Begin
Val(Copy(S,X+1,2),Code,Error);
If Error>0 then Write(S[X])
Else Begin
If Code<16 then Textcolor(Code)
Else Textbackground(Code-16);
If X + 2 > Length(S) then Inc(X,1) else Inc(X,2);
End;
End;
End;
End;
Procedure Uncrunch(var Addr1,Addr2; BlkLen:Integer);
Begin
Inline (
$1E/$C5/$B6/ADDR1/$C4/$BE/ADDR2/$8B/$8E/BLKLEN/$E3/$5B/$8B/$D7/
$33/$C0/$FC/$AC/$3C/$20/$72/$05/$AB/$E2/$F8/$EB/$4C/$3C/$10/
$73/$07/$80/$E4/$F0/$0A/$E0/$EB/$F1/$3C/$18/$74/$13/$73/$19/
$2C/$10/$02/$C0/$02/$C0/$02/$C0/$02/$C0/$80/$E4/$8F/$0A/$E0/
$EB/$DA/$81/$C2/$A0/$00/$8B/$FA/$EB/$D2/$3C/$1B/$72/$07/$75/$CC/
$80/$F4/$80/$EB/$C7/$3C/$19/$8B/$D9/$AC/$8A/$C8/$B0/$20/$74/$02/
$AC/$4B/$32/$ED/$41/$F3/$AB/$8B/$CB/$49/$E0/$AA/$1F);
End;
Procedure InputLn(var Lne : String;Chars:Byte;Caps:Boolean;Allcaps:Boolean);
Var
StartedX,Counter,OldAttr : Byte;
CH : Char;
P : String;
Done : boolean;
X : Byte;
Begin
OldAttr := Textattr;
StartedX := WhereX;
P := '';
Counter := 0;
asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}
Done := False;
For X := 1 to Chars do Write(' ');GotoXy(StartedX,WhereY);
Repeat
MemW[$0000:$041C] := MemW[$0000:$041A];
GotoXy(StartedX,WhereY);Write(Padstring(P,Chars));GotoXy(StartedX+Counter,WhereY);
CH := Readkey;If CH = #0 then CH := Readkey;
Case CH of
#8 : If Counter > 0 then
Begin
Delete(P,Length(P),1);
Dec(Counter);
End;
#13 : Done := True;
#27 : Begin
P := 'Aborted';
Done := True;
End;
#32..#126 : If Counter < Chars then
Begin
Inc(Counter);
If Caps then If (P[Counter-1] = #0) or (P[Counter-1]=#32) then CH := Upcase(CH);
If Allcaps then CH := Upcase(CH);
P := P + (CH);
End;
End;
Until Done = True;
Lne := P;
GotoXy(StartedX,WhereY);
{Textattr := 7;For X := 1 to Chars do Write(' ');}
If Lne <> 'Aborted' then Begin
GotoXy(StartedX,WhereY);
Write(Lne);
End;
Textattr := OldAttr;
End;
FUNCTION HexToLong(S : STRING) : LONGINT;
FUNCTION ANumBin (B : STRING) : LONGINT; Assembler;
ASM
LES DI, B
XOR CH, CH
MOV CL, ES : [DI]
ADD DI, CX
MOV AX, 0
MOV DX, 0
MOV BX, 1
MOV SI, 0
@LOOP :
CMP BYTE PTR ES : [DI], '1'
JNE @NotOne
ADD AX, BX {add power to accum}
ADC DX, SI
@NotOne :
SHL SI, 1 {double power}
SHL BX, 1
ADC SI, 0
DEC DI
LOOP @LOOP
END;
CONST
HexDigits : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
Legal : SET OF Char = ['$','0'..'9','A'..'F'];
BinNibbles : ARRAY [0..15] OF ARRAY [0..3] OF CHAR = (
'0000', '0001', '0010', '0011',
'0100', '0101', '0110', '0111',
'1000', '1001', '1010', '1011',
'1100', '1101', '1110', '1111');
VAR I : BYTE;
O : STRING;
BEGIN
O := '';
HexToLong := 0; { Returns zero if illegal characters found }
IF S = '' THEN EXIT;
FOR I := 1 TO LENGTH(S) DO
BEGIN
IF NOT (S[i] in LEGAL) THEN EXIT;
O := O + binNibbles[PRED(POS(S[i],Hexdigits))];
END;
HexToLong := ANumBin(O)
END;
Procedure WaitRetrace; assembler;
asm
mov dx,3DAh
@l1: in al,dx;and al,08h;jnz @l1
@l2: in al,dx;and al,08h;jz @l2
end;
Procedure FastMove(VAR source;VAR dest;numToMove : WORD);
Begin
Inline($8C/$DA/$C5/$B6/>SOURCE/$C4/$BE/>DEST/$8B/$8E/>NUMTOMOVE);
Inline($39/$FE/$72/$08/$FC/$D1/$E9/$73/$11/$A4/$EB/$0E/$FD/$01/$CE);
Inline($4E/$01/$CF/$4F/$D1/$E9/$73/$01/$A4/$4E/$4F/$F2/$A5/$8E/$DA);
End;
procedure MovW(var source,dest; num: word); assembler;
asm
push ds;les di,[dest];lds si,[source];mov cx,[num];rep movsw;pop ds
end;
Procedure qwrite(x, y : byte; s : string; f, b : byte;CharsperRow : Word);
Var
Cnter,Attrib : Word;
VidPtr : ^Word;
Begin
attrib := swap((b shl 4) + f);
vidptr := ptr($B800, 2 * (CharsPerRow * pred(y) + pred(x)));
If lastmode = 7 then dec(longint(vidptr), $08000000);
For cnter := 1 to length(s) do
Begin
vidptr^ := attrib or byte (s[cnter]);
inc(vidptr);
End;
End;
Procedure Beep(Freq,Dely : Word);
Begin
Sound(Freq);
Delay(Dely);
Nosound;
End;
Function Yesno(unlit,lit : Byte) : Boolean;
Var X,Y : Byte;
CH : Char;
Yes : Boolean;
Label GetaKey,Ending;
Begin
X := WhereX;
Y := WhereY;
asm mov ah,1; mov cx,2000h;Int 10h end; {No Cursor}
GotoXy(X,Y);
Textattr := Lit;Write(' Yes ');
Textattr := Unlit;Write(' No ');
GotoXy(X,Y);
Yes := True;
While not (CH in['Y','N',#13,#27]) do
Begin
CH := Readkey;If CH = #0 then CH := Readkey;CH := Upcase(CH);
If CH in[#75,'Y'] then Yes := True;
If CH in[#77,'N',#27] then Yes := False;
GotoXy(X,Y);
If Yes then Begin
Textattr := lit;Write(' Yes ');
Textattr := unlit;Write(' No ');
End
else Begin
Textattr := unlit;Write(' Yes ');
Textattr := lit;Write(' No ');
End;
End;
Textcolor(7);Textbackground(0);
Yesno := Yes;
End;
Procedure Row_Clear;
Const Lines : Array[1..25] of Byte =
(1,3,5,7,9,11,13,15,17,19,21,23,25,24,22,20,18,16,14,12,10,8,6,4,2);
Var X : Byte;
Begin
For X := 1 to 25 do Begin
GotoXy(1,Lines[X]);
ClrEol;
Delay(50);
End;
End;
Procedure Clear_Column(Column : Byte);
Var X : Byte;
Begin
For X := 1 to 25 do
Begin
GotoXy(Column,X);
If Column < 80 then Write(#0);
End;
End;
Procedure Column_Clear;
Const Column : Array[1..80] of Byte =
(1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,
53,55,57,59,61,63,65,67,69,71,73,75,77,79,80,78,76,74,72,70,68,66,64,62,
60,58,56,54,52,50,48,46,44,42,40,38,36,34,32,30,28,26,24,22,20,18,16,14,
12,10,8,6,4,2);
var P : Byte;
Begin
For P := 1 to 160 do
Begin
Clear_Column(Column[P]);
Delay(5);
End;
End;
Procedure Close_Vertical;
Const Column : Array[1..80] of Byte =
(1,80,2,79,3,78,4,77,5,76,6,75,7,74,8,73,9,72,10,71,11,70,12,69,13,
68,14,67,15,66,16,65,17,64,18,63,19,62,20,61,21,60,22,59,23,58,24,57,
25,56,26,55,27,54,28,53,29,52,30,51,31,50,32,49,33,48,34,47,35,46,36,
45,37,44,38,43,39,42,40,41);
Var X : Byte;
Begin
For X := 1 to 80 do Begin
Clear_Column(Column[X]);
Delay(5);
End;
End;
Procedure Close_Horizontal;
Const Row : Array[1..25] of Byte =
(1,25,2,24,3,23,4,22,5,21,6,20,7,19,8,18,9,17,10,16,11,15,12,14,13);
Var P : Byte;
Begin
For P := 1 to 25 do Begin
GotoXy(1,Row[P]);
ClrEol;
Delay(10);
End;
End;
Function Center(Str : String) : Byte;
Begin
Center := 40 - (length(Str) div 2);
End;
Function GetBitA(var a;Bit:Word):Boolean;assembler;
Const Bits:array[0..7] of Byte = ($1,$2,$4,$8,$10,$20,$40,$80);
asm
Les di,a
Mov si,bit
Mov bx,si
And si,07h
Shr bx,03h
Mov al,Byte(Bits[si])
And al,es:[di+bx]
end;
Procedure InvertBitA(var a;Bit:Word);assembler;
Const Bits:array[0..7] of Byte = ($1,$2,$4,$8,$10,$20,$40,$80);
asm
Les di,a
Mov si,bit
Mov bx,si
And si,07h
Shr bx,03h
Mov al,Byte(Bits[si])
Xor es:[di+bx],al
end;
Procedure PulltheBars;
var Y,X : Byte;
Begin
For X := 1 to 80 do
Begin
WaitRetrace;
For Y := 0 to 12 do
Begin
Mem[$b800:0000+(Y*2*160)+158] := 0;
Mem[$b800:0000+(Y*2*160)+159] := 0;
Mem[$b800:0000+((Y*2+1)*160)] := 0;
Mem[$b800:0000+((Y*2+1)*160)+1] := 0;
Fastmove(Mem[$b800:0000+(Y*2*160)+2],Mem[$b800:0000+(Y*2*160)],160-2);
Fastmove(Mem[$b800:0000+((Y*2+1)*160)],Mem[$b800:0000+((Y*2+1)*160)+2],160-2);
End;
End;
End;
Procedure SlideLeft;
Var Y,X : Byte;
Begin
For X := 1 to 80 do
Begin
WaitRetrace;
For Y := 0 to 25 do
Begin
Mem[$b800:0000+(Y*160)+158] := 0;
Mem[$b800:0000+(Y*160)+159] := 0;
Fastmove(Mem[$b800:0000+(Y*160)+2],Mem[$b800:0000+(Y*160)],160-2);
End;
End;
End;
Procedure SlideRight;
Var Y,X : Byte;
Begin
For X := 1 to 80 do
Begin
WaitRetrace;
For Y := 0 to 25 do
Begin
Mem[$b800:0000+(Y*160)] := 0;
Mem[$b800:0000+(Y*160)+1] := 0;
Fastmove(Mem[$b800:0000+(Y*160)],Mem[$b800:0000+(Y*160)+2],160-2);
End;
End;
End;
Procedure SlideUp;
Var X : Byte;
Begin
Fillword(Mem[$b800:160*25-160],80,0);
For X := 1 to 25 do
Begin
WaitRetrace;
Fastmove(Mem[$b800:0160],Mem[$b800:0000],3840);
End;
End;
Procedure SlideDown;
Var X : Byte;
Begin
FillWord(Mem[$b800:0000],80,0);
For X := 1 to 25 do
Begin
WaitRetrace;
Fastmove(Mem[$b800:0000],Mem[$b800:0160],3840);
End;
End;
function base_free : longint;
begin;
base_free := MemAvail;
end;
Function IsVesa:Boolean;
Var Regs : Registers;
Begin
regs.ax:=$4F03;
Intr($10,regs);
IsVesa:=(regs.al=$4F);
End;
begin
End.