Uses Crt;
CONST VGA=$a000;
Var Pall,Pall2 : Array[0..255,1..3] of Byte;
{--------------------------------------------------------------------------}
Procedure SetMCGA; { This procedure gets you into 320x200x256 mode. }
BEGIN
asm
mov ax,0013h
int 10h
end;
END;
{--------------------------------------------------------------------------}
Procedure SetText; { This procedure returns you to text mode. }
BEGIN
asm
mov ax,0003h
int 10h
end;
END;
{--------------------------------------------------------------------------}
procedure WaitRetrace; assembler;
label
l1, l2;
asm
mov dx,3DAh
l1:
in al,dx
and al,08h
jnz l1
l2:
in al,dx
and al,08h
jz l2
end;
{--------------------------------------------------------------------------}
Procedure GetPal(ColorNo : Byte; Var R,G,B : Byte);
Begin
Port[$3c7] := ColorNo;
R := Port[$3c9];
G := Port[$3c9];
B := Port[$3c9];
End;
{--------------------------------------------------------------------------}
Procedure Pal(ColorNo : Byte; R,G,B : Byte);
Begin
Port[$3c8] := ColorNo;
Port[$3c9] := R;
Port[$3c9] := G;
Port[$3c9] := B;
End;
{--------------------------------------------------------------------------}
Procedure Putpixel (X,Y : Integer; Col : Byte);
BEGIN
Mem [VGA:X+(Y*320)]:=Col;
END;
{--------------------------------------------------------------------------}
Procedure line(a,b,c,d,col:integer);
Function sgn(a:real):integer;
BEGIN
if a>0 then sgn:=+1;
if a<0 then sgn:=-1;
if a=0 then sgn:=0;
END;
var u,s,v,d1x,d1y,d2x,d2y,m,n:real;
i:integer;
BEGIN
u:= c - a;
v:= d - b;
d1x:= SGN(u);
d1y:= SGN(v);
d2x:= SGN(u);
d2y:= 0;
m:= ABS(u);
n := ABS(v);
IF NOT (M>N) then
BEGIN
d2x := 0;
d2y := SGN(v);
m := ABS(v);
n := ABS(u);
END;
s := INT(m / 2);
FOR i := 0 TO round(m) DO
BEGIN
putpixel(a,b,col);
s := s + n;
IF not (s<m) THEN
BEGIN
s := s - m;
a:= a +round(d1x);
b := b + round(d1y);
END
ELSE
BEGIN
a := a + round(d2x);
b := b + round(d2y);
END;
END;
END;
{--------------------------------------------------------------------------}
Procedure PalPlay;
Var Tmp : Array[1..3] of Byte;
{ This is used as a "temporary color" in our pallette }
loop1 : Integer;
BEGIN
Move(Pall[200],Tmp,3);
{ This copies color 200 from our virtual pallette to the Tmp variable }
Move(Pall[0],Pall[1],200*3);
{ This moves the entire virtual pallette up one color }
Move(Tmp,Pall[0],3);
{ This copies the Tmp variable to the bottom of the virtual pallette }
WaitRetrace;
For loop1:=1 to 255 do
pal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
END;
{--------------------------------------------------------------------------}
Procedure SetUpScreen;
Var Loop : Integer;
BEGIN
FillChar(Pall,SizeOf(Pall),0);
{ Clear the entire PALL variable to zero. }
For Loop := 0 to 200 do BEGIN
Pall[Loop,1] := Loop mod 64;
END;
{ This sets colors 0 to 200 in the PALL variable to values between
0 to 63. the MOD function gives you the remainder of a division,
ie. 105 mod 10 = 5 }
For Loop := 1 to 320 do BEGIN
Line(319,199,320-Loop,0,(Loop Mod 199)+1);
Line(0,0,Loop,199,(Loop Mod 199)+1);
{ These two lines start drawing lines from the left and the right
hand sides of the screen, using colors 1 to 199. Look at these
two lines and understand them. }
PalPlay;
{ This calls the PalPlay procedure }
END;
END;
{--------------------------------------------------------------------------}
Procedure GrabPallette;
VAR loop1:integer;
BEGIN
For loop1:=0 to 255 do
Getpal (loop1,pall2[loop1,1],pall2[loop1,2],pall2[loop1,3]);
END;
{--------------------------------------------------------------------------}
Procedure Blackout;
{ This procedure blackens the screen by setting the pallette values of
all the colors to zero. }
VAR loop1:integer;
BEGIN
WaitRetrace;
For loop1:=0 to 255 do
Pal (loop1,0,0,0);
END;
{--------------------------------------------------------------------------}
Procedure HiddenScreenSetup;
VAR loop1,loop2:integer;
BEGIN
For loop1:=0 to 319 do
For loop2:=0 to 199 do
PutPixel (loop1,loop2,Random (256));
END;
{--------------------------------------------------------------------------}
Procedure Fadeup;
VAR loop1,loop2:integer;
Tmp : Array [1..3] of byte;
{ This is temporary storage for the values of a color }
BEGIN
For loop1:=1 to 64 do BEGIN
{ A color value for Red, green or blue is 0 to 63, so this loop only
need be executed a maximum of 64 times }
WaitRetrace;
For loop2:=0 to 255 do BEGIN
Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
If Tmp[1]<Pall2[loop2,1] then inc (Tmp[1]);
If Tmp[2]<Pall2[loop2,2] then inc (Tmp[2]);
If Tmp[3]<Pall2[loop2,3] then inc (Tmp[3]);
{ If the Red, Green or Blue values of color loop2 are less then they
should be, increase them by one. }
Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
{ Set the new, altered pallette color. }
END;
END;
END;
{--------------------------------------------------------------------------}
Procedure FadeDown;
VAR loop1,loop2:integer;
Tmp : Array [1..3] of byte;
{ This is temporary storage for the values of a color }
BEGIN
For loop1:=1 to 64 do BEGIN
WaitRetrace;
For loop2:=0 to 255 do BEGIN
Getpal (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]);
{ If the Red, Green or Blue values of color loop2 are not yet zero,
then, decrease them by one. }
Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
{ Set the new, altered pallette color. }
END;
END;
END;
{--------------------------------------------------------------------------}
Procedure RestorePallette;
VAR loop1:integer;
BEGIN
WaitRetrace;
For loop1:=0 to 255 do
pal (loop1,Pall2[loop1,1],Pall2[loop1,2],Pall2[loop1,3]);
END;
BEGIN
SetMCGA;
GrabPallette;
SetUpScreen;
repeat
PalPlay;
{ Call the PalPlay procedure repeatedly until a key is pressed. }
Until Keypressed;
RestorePallette;
SetText;
END.
Правила форума
Внимание! Действует предмодерация
Салфетка Серпинского:
