unit control;
INTERFACE
uses crt,dos;
const
m_symbols : string[31]='~^"!?@#$%&()[]<>| _-+=*/\.:,;'+#96+#123+#125;
m_upCase : string[26]='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
m_lowCase : string[26]='abcdefghijklmnopqrstuvwxyz';
m_numbers : string[10]='1234567890';
m_letters : string[42]='';
m_ascii : string[93]='';
var
font : array[1..4096] of byte;
pall2 : array[0..63,1..3] of byte;
function upstring(str : string) : string;
procedure flushbuffer;
procedure cursor_On;
procedure cursor_Off;
procedure waitRetrace;
Procedure iceCol_On;
Procedure iceCol_Off;
Procedure set8x16font;
procedure equalize;
procedure mode3h;
procedure Lines200; { Set 200 scanlines on VGA display }
procedure Lines350; { Set 350 scanlines on VGA display }
procedure Lines400; { Set 400 scanlines on VGA display }
procedure vFine(y:byte);
procedure setPal(col,r,g,b : byte);
procedure getPal(col : byte; Var r,g,b : byte);
procedure savepal;
procedure restorepal;
procedure fadeDown;
procedure fadeWhite;
procedure unFade;
procedure blackOut;
procedure cls(size:word);
function col(fore:byte;back:byte): byte;
procedure fastText(x, y : word; col : byte; what : string);
procedure setVgaFont;
function inputStr(x,y,color,maxLen : byte; strBuff: string): string;
function num(strToConv: string): integer;
{function strng(intToConv:longInt): string;}
IMPLEMENTATION
{--[ d o s f o n t ]--------------------------------------------------------}
{----------------------------------------------------------------------------}
procedure setVgaFont;
{font_data is a 4096 byte array that contains the entire font data to be
passed to the interrupt}
var regs:registers; { pascal registers }
begin
regs.bx:=(16*256);{0x1000; {16 scanline font}
regs.es:=seg(font); {segment of the font data}
regs.bp:=ofs(font); {offset of the font data}
regs.ax:=((17*256)+16); {0x1110; {int 10h subfunction}
regs.cx:=256; {256 characters}
regs.dx:=0; {start with char #0}
Intr(16, Regs); {load actual data $10}
end;
Procedure set8x16font;assembler;
asm
mov dx,03c4h
mov ax,0100h
out dx,ax
mov dx,03c4h
mov ax,0301h
out dx,ax
{ mov dx,03c2h
mov al,063h
out dx,al
mov dx,03c4h
mov ax,0300h
out dx,ax
mov dx,03d4h
mov ax,4f09h
out dx,ax}
end;
procedure equalize; assembler;
asm
mov dx,03c2h
mov al,063h
out dx,al
end;
{--[ s c r e e n m o d e s ]------------------------------------------------}
{----------------------------------------------------------------------------}
procedure waitRetrace; assembler;
asm
mov dx,3DAh
@@11:
in al,dx
and al,08h
jnz @@11
@@12:
in al,dx
and al,08h
jz @@12
end;
procedure iceCol_On;assembler;
asm
mov bl,0000h
mov ax,1003h
int 10h
end;
procedure iceCol_Off;assembler;
asm
mov bl,0001h
mov ax,1003h
int 10h
end;
procedure mode3h; assembler;
asm
mov ax, 3h
int 10h
end;
procedure Lines200; assembler; { Set 200 scanlines on VGA display }
asm
mov ax, 1200h
mov bl, 30h
int 10h
end;
procedure Lines350; assembler; { Set 350 scanlines on VGA display }
asm
mov ax, 1201h
mov bl, 30h
int 10h
end;
procedure Lines400; assembler; { Set 400 scanlines on VGA display }
asm
mov ax, 1202h
mov bl, 30h
int 10h
end;
procedure vFine(y:byte); assembler;
asm
mov dx,03dah
{@W2:
in al,dx
test al,8
jz @W2}
{ sti;}
mov dx,03d4h
mov ah,Y
mov al,8
out dx,ax
end;
{--[ p a l l e t t e ]-------------------------------------------------------}
{----------------------------------------------------------------------------}
procedure setPal(col,r,g,b : byte); assembler;
asm
mov dx,3c8h
mov al,[col]
out dx,al
inc dx
mov al,[r]
out dx,al
mov al,[g]
out dx,al
mov al,[b]
out dx,al
end;
procedure getPal(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;
procedure savepal;
var loop1:integer;
begin
for loop1 := 0 to 63 do
getPal(loop1,pall2[loop1,1],pall2[loop1,2],pall2[loop1,3]);
end;
procedure restorepal;
var loop1:integer;
begin
waitRetrace;
for loop1 := 0 to 63 do
setPal(loop1,pall2[loop1,1],pall2[loop1,2],pall2[loop1,3]);
end;
procedure fadeDown;
var loop1,loop2 : byte;
Tmp : Array [1..3] of byte;
begin
for loop1 := 1 to 64 do begin
waitRetrace;
for loop2 := 0 to 63 do begin
getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
if Tmp[1]>0 then dec (Tmp[1],round(tmp[1]/(64-loop1)+1));
if Tmp[2]>0 then dec (Tmp[2],round(tmp[2]/(64-loop1)+1));
if Tmp[3]>0 then dec (Tmp[3],round(tmp[3]/(64-loop1)+1));
setPal (loop2,Tmp[1],Tmp[2],Tmp[3]);
end;
end;
end;
procedure fadeWhite;
var loop1,loop2 : byte;
tmp : Array [1..3] of byte;
begin
for loop1 := 1 to 64 do begin
WaitRetrace;
for loop2 := 0 to 63 do begin
getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
if Tmp[1]<63 then inc (Tmp[1]);
if Tmp[2]<63 then inc (Tmp[2]);
if Tmp[3]<63 then inc (Tmp[3]);
setPal (loop2,Tmp[1],Tmp[2],Tmp[3]);
end;
end;
end;
procedure unFade;
var loop1,loop2 : byte;
tmp : Array [1..3] of byte;
begin
for loop1 := 1 to 64 do begin
waitRetrace;
for loop2 := 0 to 63 do begin
Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
if Tmp[1]<Pall2[loop2,1] then inc (Tmp[1]);
if Tmp[1]>Pall2[loop2,1] then dec (Tmp[1]);
if Tmp[2]<Pall2[loop2,2] then inc (Tmp[2]);
if Tmp[2]>Pall2[loop2,2] then dec (Tmp[2]);
if Tmp[3]<Pall2[loop2,3] then inc (Tmp[3]);
if Tmp[3]>Pall2[loop2,3] then dec (Tmp[3]);
SetPal (loop2,Tmp[1],Tmp[2],Tmp[3]);
end;
end;
end;
procedure blackOut;
var
loop:byte;
begin
for loop:=0 to 63 do setPal(loop,0,0,0);
end;
procedure cls(size:word);
begin
fillChar(mem[$b800:0],size,0);
end;
{--[ c h a r a c t e r s ]---------------------------------------------------}
{----------------------------------------------------------------------------}
procedure flushbuffer; assembler;
asm
mov ax, $0C00;
int 21h;
end;
procedure cursor_On; Assembler;
asm
mov ax,0100h
mov cx,0506h
int 10h
end;
procedure cursor_Off; assembler;
asm
mov ax,0100h
mov cx,02607h
int 10h
end;
function col(fore:byte;back:byte): byte;
begin
col:=fore+(back*16)
end;
procedure fastText(x, y : word; col : byte; what : string); assembler;
asm
push ds
dec [x]
dec [y]
mov ax, 0b800h
mov es, ax
mov ax, [y]
mov bl, 160
mul bl
add ax, [x]
add ax, [x]
mov di, ax
lds si, what
cld
lodsb
xor ch, ch
mov ah, [col]
mov cl, al
cmp cx, 0
jz @@2
@@1: lodsb
stosw
loop @@1
@@2:
pop ds
end;
function inputStr(x,y,color,maxLen : byte; strBuff: string): string;
var
continue : boolean;
insertOn : boolean;
strBack : string;
keyBuff : char;
ascKey : byte;
curPos : byte;
strLen : byte;
begin
continue:=true;
insertOn:=true;
strBack:=strBuff;
strLen:=length(strBuff);
curPos:=length(strBuff);
cursor_on;
while continue do
begin
fastText(x,y,color,strBuff+' ');
gotoXY(x+curPos,y);
keyBuff:=readKey;
ascKey:=ord(keyBuff);
if (keyBuff = #8) then begin
if (curPos > 0) then begin
delete(strBuff,curPos,1);
dec(curPos);
dec(strLen);
end;
end
else if (keyBuff = #13) then begin
inputStr:=strBuff;
continue:=false;
end
else if (keyBuff = #27) then begin
strBuff:=strBack;
curPos:=0;
continue:=false;
inputStr:=strBack;
end
else if (keyBuff=#0) then begin
keyBuff:=readKey;
if keyBuff=#71 then begin {g}
curPos:=0;
end
else if keyBuff=#75 then begin
if (curPos > 0) then dec(curPos);
end
else if keyBuff=#77 then begin
if (curPos < strLen) then inc(curPos) else
begin
inputStr:=strBuff;
continue:=false;
end;
end
else if keyBuff=#82 then begin {r}
if insertOn=true then begin
insertOn:=false;
end
else if insertOn=false then begin
insertOn:=true;
end;
end
else if keyBuff=#83 then begin {s}
if (strLen > curPos) then begin
delete(strBuff,curPos+1,1);
dec(strLen);
end;
end
else if keyBuff=#79 then begin {o}
curPos:=strLen;
end;
end
else if (strLen < maxLen) and (insertOn=true) then begin
inc(curPos);
inc(strLen);
insert(keyBuff,strBuff,curPos);
end
else if not (curPos = maxLen) and (insertOn=false) then begin
inc(curPos);
if curPos-1=strLen then begin
inc(strLen);
strBuff:=strBuff+' ';
end;
strBuff[curPos]:=keyBuff;
end;
end;
cursor_off;
end;
function num(strToConv: string): integer;
var
codeErr : integer;
intBuff : integer;
begin
val(strToConv, intBuff, codeErr);
num:=intBuff;
end;
function strng(intToConv:longInt): string;
var
strBuff : string;
begin
str(intToConv, strBuff);
strng:=strBuff;
end;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
function upstring(Str : String) : String;
Var X : Byte;
Begin
For X := 1 to Length(Str) do Str[X] := Upcase(Str[X]);
upString := Str;
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
begin
m_letters:=m_upCase+m_lowCase;
m_ascii :=m_symbols+m_letters+m_numbers;
end.