{--------}Unit TxEffect;{----------}
{$G+,E-,N+}
INTERFACE
const
RunLine = 0;
FromCenterRunLine = 1;
RunChars = 2;
FallLine = 3;
FallChars = 4;
FromcenterMoveLine= 5;
const
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta= 13;
Yellow = 14;
White = 15;
Blink = 128;
const
CurPgOffset : Word = 0;
Procedure StringEffect(var S:String;X0,X,Y,TxColor,TxBkColor,
WriteMode:Byte;Pause:LongInt;
RandomTxColor,RandomTxBkColor,DifChar:Boolean) ;
Procedure SetTxPoint(X,Y,ColorTx,BkColorTx:Byte;C:Char);
Procedure LineTx(X1, Y1, X2, Y2 : Byte; ColorTX, BkColor : Byte; C : Char);
Procedure FillBarTx(X1, Y1, X2, Y2, ChColor, BkChColor, FillChColor,
FillBkChColor : Byte; C, FillC : Char);
Procedure ArcTx(X, Y, RadX, RadY: Byte; BgAngle, EndAngle: Word;
ChColor, BkChColor, FillChColor, FillBkChColor : Byte;
C, FillC : Char);
Function Other(C:Char):Char;
Procedure Delay(P : LongInt);
Procedure CursorOn;
Procedure CursorOff;
Procedure SetViewPage(Pg : Byte);
Procedure SetCurPage(Pg : Byte);
Procedure SetColorPal(Attr : Word);{0|Color èëè 1[256]|NmbPal[0..3]}
Procedure SetPalReg(reg, col : Byte);
Procedure SetBorderColReg(col : Byte);
Procedure ToggleIntense_Blink(b : Byte);{0 - Intense/ 1 - Blink}
Procedure SetWidth8;
Procedure SetWidth9;
{--------------------}
Implementation
Uses CRT;
Procedure SetCurPage(Pg : Byte);
begin
CurPgOffset := Pg*4000;
end;
Procedure SetViewPage(Pg : Byte);Assembler;
asm
mov al, byte ptr Pg
mov ah, 5
int 10h
end;
Procedure CursorOff;Assembler;
asm
mov ah, 1
mov ch, $20
int $10
end;
{------------------}
Procedure CursorOn;Assembler;
asm
mov ah, 1
mov ch, 6
mov cl, 7
int $10
end;
Procedure SetColorPal(Attr : Word); Assembler;
asm
mov ah, 0Bh
mov bx, word ptr Attr
int 10h
end;
Procedure SetPalReg(reg, col : Byte);Assembler;
asm
mov ax, 1000h
mov bl, byte ptr reg
mov bh, byte ptr col
end;
Procedure SetBorderColReg(col : Byte);Assembler;
asm
mov ax, 1001h
mov bh, byte ptr col
end;
Procedure ToggleIntense_Blink(b : Byte);Assembler;
asm
mov bl, byte ptr b
mov ax, 1003h
int 10h
end;
Procedure SetWidth8;Assembler;
asm
{ mov dx, 03C4h
xor al, al
out dx, al
inc dx
in al, dx
and al, 0FEh
out dx, al
dec dx}
mov dx, 03C4h
mov al, 01h
out dx, al
inc dx
in al, dx
or al, 01h
out dx, al
end;
Procedure SetWidth9;Assembler;
asm
mov dx, 03C4h
mov al, 01h
out dx, al
inc dx
in al, dx
and al, 0FEh
out dx, al
end;
Procedure Delay(P : LongInt);
var
d : Word;
begin
asm
mov word ptr d, 0
@1:
inc word ptr d
cmp word ptr d, 300
je @2
mov cx, Word Ptr P + 2
mov dx, Word Ptr P
mov ah, $86
int $15
jc @1
@2:
end;
end;
Procedure StringEffect(var S:String; X0,X,Y,TxColor,TxBkColor,
WriteMode:Byte;Pause:LongInt;
RandomTxColor,RandomTxBkColor,DifChar:Boolean) ;
var
i,j:Integer;
S1:String;
Procedure ColorCase;
begin
case RandomTxColor of
false:TextColor(TxColor);
true:TextColor(Round(random(15))+1);
end;
case RandomTxBkColor of
false:TextBackGround(TxBkColor);
true: TextBackGround(Round(random(7)));
end;
end;
Procedure DifCharCase(SS:String);
var
j : Integer;
begin
case DifChar of
False:
begin
ColorCase;
Write(SS);
end;
True:
begin
for j := 1 to Length(SS) do
begin
ColorCase;
Write(SS[j]);
Delay(Pause);
end
end;
end;
end;
begin
Randomize;
case WriteMode of
RunLine:
begin
for i := X0 to X do
begin
GotoXY(i, Y);
TextBackGround(TxBkColor);
{!*!} ClrEOL;
case DifChar of
false:
begin
ColorCase;
Write(S);
end;
true :
begin
for j := 1 to Length(S) do
begin
ColorCase;
Write(S[j]);
Delay(Pause);
end;
end
end;
end;
end;
FromCenterRunLine :
begin
if Odd(Length(S)) then S := S+' ';
for i := 1 to Length(S) div 2 do
begin
GotoXY(X0-i, Y);
S1 := S;
if i <> (Length(S) div 2) then Delete(S1, i+1, Length(S)-2*i);
DifCharCase(S1);
Delay(Pause);
end;
end;
RunChars:
begin
for i := 1 to Length(S) do
if X0 < X then
for j := X0 to X do
begin
GotoXY(j+i-1, Y);
TextBackGround(TxBkColor);
ClrEOL;
DifCharCase(S[j]);
Delay(Pause);
end
else
for j := X0 downto X do
begin
GotoXY(j+i-1, Y);
TextBackGround(TxBkColor);
ClrEOL;
DifCharCase(S[j]);
Delay(Pause);
end;
end;
FallLine:
begin
if X0 < X then
for i := X0 to X do
if i <> X0 then
begin
GotoXY(Y, i-1);
TextBackGround(TxBkColor);
ClrEOL;
DifCharCase(S);
Delay(Pause);
end
else
for i := X0 downto X do
if i <> X0 then
begin
GotoXY(Y, i-1);
TextBackGround(TxBkColor);
ClrEOL;
DifCharCase(S);
Delay(Pause);
end;
end;
FallChars:
begin
for i := 1 to Length(S) do
if X0 < X then
for j := X0 to X do
begin
if j <> X0 then
begin
GotoXY(Y, j-1);
TextBackGround(TxBkColor);
ClrEOL;
end;
GotoXY(Y, j);
DifCharCase(S[j]);
Delay(Pause);
end
else
for j := X0 downto X do
begin
if j <> X0 then
begin
GotoXY(Y, j-1);
TextBackGround(TxBkColor);
ClrEOL;
end;
GotoXY(Y, j);
DifCharCase(S[j]);
Delay(Pause);
end;
end;
FromCenterMoveLine:
begin
if Odd(Length(S)) then S := S + ' ';
for i := 1 to Length(S) div 2 do
begin
GotoXY(X0-i, Y);
DifCharCase(Copy(S, (Length(S) div 2) - i, i*2));
end;
end;
end;
end;
{[][][][][][][][][][][][}
Procedure SetTxPoint(X,Y,ColorTx,BkColorTx:Byte;C:Char);Assembler;
asm
push ds
mov ax, $B800
mov ds, ax
xor ah, ah
xor bh, bh
mov bl, byte ptr x
cmp bx, 80
ja @1
mov al, byte ptr y
cmp ax, 25
ja @1
dec ax
mov cl, 80
mul cl
add ax, word ptr CurPgOffset
dec bx
add bx, ax
mov cl, byte ptr ColorTx
and cl, $8F
mov dl, BkColorTx
mov al, dl
and dl, $7
shl dl, 4
and al, $80
or dl, al
or dl, cl
mov al, byte ptr C
mov ah, dl
shl bx, 1
mov ds:[bx], ax
@1:
pop ds
end;
Procedure LineTx(X1, Y1, X2, Y2 : Byte; ColorTX, BkColor : Byte; C : Char);
var
i : Integer;
dx, dy, D : Real;
begin
D := sqrt(sqr(X1-X2)+sqr(Y1-Y2));
if D <> 0 then
begin
dX := (X2-X1)/D;
dY := (Y2-Y1)/D;
end;
for i := 0 to Round(D) do
SetTxPoint(X1 + Round(dX*i), Y1 + Round(dY*i), ColorTx, BkColor, C)
end;
Procedure FillBarTx(X1, Y1, X2, Y2, ChColor, BkChColor, FillChColor,
FillBkChColor : Byte; C, FillC : Char);
var
i, j, X, Y : Byte;
begin
if X1 360 then z := True else z := False;
if z then
begin
A := Pi/2;
Ya := Round(Y + RadY*sin(A));
Yb := Round(Y + RadY*sin(Grad*180+A));
for i := 0 to 180 do
begin
X1 := Round(X + RadX*cos(Grad*i+A));
Y1 := Round(Y + RadY*sin(Grad*i+A));
if (Y1>Yb) and (Y1
< -->