var
konec:boolean;
VirScr:VirtPtr;
Vaddr:word;
font:pointer;
height: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 Cls (Col : Byte; Where:word);
{ This clears the screen to the specified color }
BEGIN
asm
push es
mov cx, 32000;
mov es,[where]
xor di,di
mov al,[col]
mov ah,al
rep stosw
pop es
End;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Putpixel (X,Y : Integer; Col : Byte; where:word);
{ This puts a pixel on the screen by writing directly to memory. }
BEGIN
Asm
push ds
push es
mov ax,[where]
mov es,ax
mov bx,[X]
mov dx,[Y]
push bx {; and this again for later}
mov bx, dx {; bx = dx}
mov dh, dl {; dx = dx * 256}
xor dl, dl
shl bx, 1
shl bx, 1
shl bx, 1
shl bx, 1
shl bx, 1
shl bx, 1 {; bx = bx * 64}
add dx, bx {; dx = dx + bx (ie y*320)}
pop bx {; get back our x}
add bx, dx {; finalise location}
mov di, bx
{; es:di = where to go}
xor al,al
mov ah, [Col]
mov es:[di],ah
pop es
pop ds
End;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure WaitRetrace; assembler;
{ This waits for a vertical retrace to reduce snow on the screen }
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 SetUpVirtual;
{ This sets up the memory needed for the virtual screen }
BEGIN
GetMem (VirScr,64000);
vaddr := seg (virscr^);
{GetMem (VirScr2,64000);
vaddr2 := seg (virscr2^);}
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure ShutDown;
{ This frees the memory used by the virtual screen }
BEGIN
FreeMem (VirScr,64000);
{FreeMem (VirScr2,64000);}
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure flip(source,dest:Word);
{ This copies the entire screen at "source" to destination }
begin
asm
push ds
mov ax, [Dest]
mov es, ax
mov ax, [Source]
mov ds, ax
xor si, si
xor di, di
mov cx, 32000
rep movsw
pop ds
end;
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetPal(ColorNo : Byte; Var R,G,B : Byte);
{ This reads the values of the Red, Green and Blue values of a certain
color and returns them to you. }
Begin
Port[$3c7] := ColorNo;
R := Port[$3c9];
G := Port[$3c9];
B := Port[$3c9];
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Pal(ColorNo : Byte; R,G,B : Byte);
{ This sets the Red, Green and Blue values of a certain color }
Begin
Port[$3c8] := ColorNo;
Port[$3c9] := R;
Port[$3c9] := G;
Port[$3c9] := B;
End;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure GrabPalette(var XPalette : tPal);
{Naplni zvolenou promenou typu tPal paletou jakou chci}
var loop1:integer;
begin
for loop1:=0 to 255 do
GetPal(loop1, XPalette[loop1,1], XPalette[loop1,2], XPalette[loop1,3]);
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure RestorePalette(XPalette : tPal);
{Nastavy paletu jakou chci}
var loop1:integer;
begin
for loop1:=0 to 255 do
Pal(loop1, XPalette[loop1,1], XPalette[loop1,2], XPalette[loop1,3]);
end;
var
FirstChar,
CharHeight :Byte;
CharNr,
ScreenPTR :Word;
asm
push ds
mov ax,where { Setup ES:[BX] = X,Y to plot at }
mov es,ax
mov bx,x
mov ax,y
xchg ah,al
add bx,ax
shr ax,2
add bx,ax
lds di,font
mov dl,[di] { height of font goes into dh }
mov CharHeight,dl
inc di
mov dl,[di]
mov FirstChar,dl
mov CharNr,0 { Ugh! Character counter, not a very }
{ good method, but I'm all out of registers :-( }
@nextchar:
inc CharNr { also skips lengthbyte! }
push ds { This I don't like, pushing and popping. }
lds si,[S] { But unfortunately I can't seem to find }
add si,CharNr { any spare registers? Intel, can you help? }
lodsb { load asciivalue into al }
pop ds
cmp al,0 { check for null-termination }
je @exit { exit if end of string }
mov ScreenPTR,BX { save bx }
mov dh,CharHeight
xor ah,ah
mov cl,firstchar { firstchar }
sub al,cl { al = currentchar - firstchar }
mov si,ax { di = scrap register }
mul dh { ax * fontheight }
add ax,si { ax + characters to skip }
lds di,font { This can be omptimized I think (preserve DI) }
add di,3 { skip header }
add di,ax { Point into structure }
mov cl,[di] { get character width }
@nextline:
mov ch,cl { ch is the height counter. cl is the original. }
inc di { .. now points to bitmap }
mov dl,[di] { get bitmap byte }
@nextpixel:
rol dl,1 { rotate bitmap and prepare for next pixel }
mov al,dl { mov bitmap into al for manipulation }
and al,1 { mask out the correct bit }
jz @masked { jump if transperent }
mov al,color
mov byte ptr es:[bx],al { Set the pixel on the screen }
@masked:
inc bx { increment X-offset }
dec ch { are we done? last byte in character? }
jnz @nextpixel { nope, out with another pixel }
add bx,320 { Go to next line on the screen }
sub bx,cx { X-alignment fixup }
dec dh { are we done with the character? }
jnz @nextline
mov bx,ScreenPTR { restore screen offset and prepare for next character }
add bx,cx
inc bx { A little gap between the letters, thank you... }
jmp @nextchar
@exit:
pop ds
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure Game;
var
loopG:integer;
GameOver:boolean;
Auto:tAuto;
Plocha:tPlocha;
Counter:longint;
Xxloop:byte;
{*************** Procedurky a Fce ****************}
procedure PutFrame(x,y:integer;XFrame:icon; where:word);
var i,j:integer;
begin
for i:=1 to 15 do
for j:=1 to 15 do
if XFrame[(i-1)*15+j]<>0 then
putpixel(x*15+j-1,y*15+i-1,XFrame[(i-1)*15+j],where);
end;
procedure initFirst(var xAuto:tAuto; var xPlocha:tPlocha);
var i,j:byte;
begin
xAuto.x:=10;
xAuto.xStary:=xAuto.x;
xAuto.y:=Delka;
for i:=1 to delka do
begin
xPlocha[i,1] :=wall;
xPlocha[i,sirka]:=wall;
for j:=2 to sirka-1 do xPlocha[i,j]:=empty;
end;
end;
procedure ZobrazG (var xPlocha:tPlocha; var XCount: longint);
var i,j:byte;
ss:string[8];
begin
Cls(16,Vaddr);
for i:=1 to delka do
for j:=1 to sirka do
if xPlocha[i,j]=wall then PutFrame((j-1),(i-1),fWall,Vaddr);
str(XCount,ss);
XYText(font,240,10,35,'SCORE:'+#0,vaddr);
XYText(font,240,10+height,38,ss+#0,vaddr);
WaitRetrace;
flip(Vaddr,VGA);
end;
procedure ZobrazA (var xAuto:tAuto);
var i,j:integer;
begin
if xAuto.x <> xAuto.xStary then
for i:=(delka-1)*15 to (delka)*15 do
for j:= (xAuto.xStary-1)*15 to xAuto.xStary*15 do PutPixel(j,i,0,VGA);
PutFrame(xAuto.x-1,delka-1,fAuto,VGA);
xAuto.xStary:=xAuto.x;
end;
procedure Vlevo (var xAuto:tAuto; var xPlocha:tPlocha);
begin
if xPlocha[xAuto.y,xAuto.x-1]=empty then xAuto.x:=xAuto.x-1;
end;
procedure Vpravo(var xAuto:tAuto; var xPlocha:tPlocha);
begin
if xPlocha[xAuto.y,xAuto.x+1]=empty then xAuto.x:=xAuto.x+1;
end;
procedure Dalsi (var xPlocha:tPlocha);
var i,j:byte;
begin
for i:=delka downto 2 do
for j:= 2 to sirka-1 do xPlocha[i,j]:=xPlocha[i-1,j];
for j:=2 to sirka-1 do
begin
if random(Hustota)=0 then xPlocha[1,j]:=wall
else xPlocha[1,j]:=empty;
end;
end;
function Ovladani:tOvladani;
var
Znak:char;
begin
Znak:=readkey;
if ord(Znak)=Dvoji then {Cteni znaku s dvojim nacitanim}
begin
Znak:=readkey;
case ord(Znak) of
75: Ovladani:= levo;
77: Ovladani:= pravo;
end;
end
else
if ord(Znak)= 27 then Ovladani:= Esc;
end;
procedure KonecHrac;
begin
cls(0,VGA);
XYText(font,30,100-height,42,'*************************'+#0,VGA);
XYText(font,30,100,38, '**** !!! KONEC !!! ****'+#0,VGA);
XYText(font,30,100+height,42,'*************************'+#0,VGA);
repeat until keypressed;
end;
function Koncis(xAuto:tAuto;xPlocha:tPlocha):boolean;
begin
if xPlocha[delka-1,xAuto.x]= wall then koncis:=true
else koncis:= false;
end;
begin {Main GAME}
initFirst(Auto,Plocha);
GameOver:=false;
Counter:=0;
XxLoop:=10;
SetUpVirtual;
Cls(0,VGA);
Cls(0,Vaddr);
repeat
ZobrazG(Plocha,Counter);
ZobrazA(Auto);
for loopG:=1 to XxLoop do
begin
WaitRetrace;
ZobrazA(Auto);
if keypressed then
begin
case Ovladani of
levo : Vlevo (Auto,Plocha);
pravo: Vpravo(Auto,Plocha);
esc : GameOver:=true;
end;
end;
end;
Counter:=Counter+1;
if ((counter mod 30)=0)and(XxLoop > 2)then XxLoop:=Xxloop-1;
if GameOver then KonecHrac{Ukonceno uzivatelem}
else
if Koncis(Auto,Plocha) then
begin
GameOver:=true; {Uzivatel prohral}
XYText(font,30,100,45,'Ha Ha NARAZILS !!!!'+#0,VGA);
readln;
end
else Dalsi(Plocha); {Pokracovani hry}
until GameOver;
ShutDown;
end; {Main GAME}
procedure PutLogo;
var i,j:integer;
begin
for i:=1 to 15 do
for j:=1 to 66 do
if logo[(i-1)*66+j]<>0 then
putpixel(ROUND((320-66)/2)+j-1,ROUND((200-15)/2)+i-1,51,VGA);
end;
procedure HLine (y:integer; col:byte; where:word);
var loop:integer;
begin
for loop:=0 to 319 do putpixel(loop,y,col,where);
end;
procedure PalPlay;
var
loop1,loop2:integer;
R,G,B:byte;
begin
for loop1:=1 to 50 do
begin
delay(waitx+50);
waitretrace;
for loop2:=1 to loop1 do
begin
GetPal(loop2,R,G,B);
Pal(loop2,R+1,0,0);
end;
end;
end;
procedure RedUp;
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:=1 to 50 do
BEGIN
Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
If Tmp[1]<63 then inc (Tmp[1]);
Pal (loop2,Tmp[1],0,0);
{ Set the new, altered pallette color. }
END;
delay(waitx);
END;
END;
Procedure Fadeup;
{ This procedure slowly fades up the new screen }
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:=1 to 50 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]);
Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
{ Set the new, altered pallette color. }
END;
delay(waitx);
END;
END;
Procedure FadeOut;
{ This procedure slowly fades up the new screen }
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:=1 to 50 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]);
Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
{ Set the new, altered pallette color. }
END;
delay(waitx);
END;
END;
procedure Obdelniky1;
var
loop1,loop2,loop3:integer;
helpX,helpY,x,y:integer;
begin
for loop1:=0 to 48 do
begin
y:=200-loop1*4;
x:=round(8*y/5);
helpX:=round((320-x)/2);
helpY:=loop1*2;
for loop2:=helpy to Helpy+y-1 do
for loop3:=helpx to helpx+x-1 do putpixel(loop3,loop2,loop1+1,VGA);
end;
end;
begin
SetUpVirtual;
Cls(0,Vaddr);
Cls(0,VGA);
GrabPalette(OldPal);
for i:=1 to 51 do pal(i,0,0,0);
for i:=0 to 49 do
for j:=0 to 3 do
HLine(i*4+j,i+1,VGA);
PutLogo;
Palplay;
RedUp;
FadeUp;
Obdelniky1;
for i:=1 to 50 do
begin
waitretrace;
pal(i,64-i,64-i,64-i);
delay(30);
end;
fadeout;
for i:=1 to 50 do
begin
waitretrace;
pal(i,64-i,64-i,0);
delay(30);
end;
for i:=1 to 25 do
begin
waitretrace;
pal(i,0,0,64-i);
delay(30);
end;
for i:=26 to 50 do
begin
waitretrace;
pal(i,0,0,14+i);
delay(30);
end;
j:=0;
pal(51,0,0,0);
pal(52,0,0,0);
XYText(font,round((320-5*9)/2),80,51, 'FUNNY'+#0,VGA);
XYText(font,round((320-5*9)/2),100,52,'SPACE'+#0,VGA);
for i:=0 to 63 do
begin
pal(51,i,0,0);
pal(52,i,i,0);
delay(20);
end;
fadeout;
delay(500);
waitretrace;
cls(0,VGA);
RestorePalette(OldPal);
ShutDown;
end;
procedure JaJenJA;
begin
cls(0,VGA);
XYText(font,120+4,1*height,32,'WRITTEN'+#0,VGA);
delay(500);
XYText(font,120,3*height,35,'DESIGNED'+#0,VGA);
delay(500);
XYText(font,120,5*height,38,'ANIMATED'+#0,VGA);
delay(500);
XYText(font,120,7*height,41,' BY '+#0,VGA);
delay(500);
XYText(font,120,9*height,44,' ALESEK '+#0,VGA);
repeat until keypressed;
readkey;
end;
procedure ZobrazHLm;
begin
XYText(font,0,0,32,'Start hry.........s'+#0,VGA);
XYText(font,0,Height,33,'Credits...........c'+#0,VGA);
XYText(font,0,2*Height,34,'Konec...........ESC'+#0,VGA);
end;
function HLmenu:tHLmenu;
var
Znak:char;
begin
Znak:=readkey;
case Znak of
's','S': HLmenu:= start;
'c','C': HLmenu:= credit;
chr(27): HLmenu:= konci;
end;
end;
var f:file;
fsize:word;
begin {Main program}
clrscr;
Assign(f,'rose.dat');{Mozna bude potreba upravit tuto cesu k danemu souboru}
{$I-}
Reset(f,1);
{$I+}
if IOresult <> 0 then
begin
writeln('Nenasel jsem soubor s fontem - rose.dat');
writeln('Nejspis bude potreba upravit cestu na radku 766 nebo ->');
writeln('Pokud spoustite program v kompilatoru musi byt soubor');
writeln('umisten v c:\rose.dat.');
writeln('Jinak jestli spoustite zkompilovanou verzi (*.exe) musi');
writeln('byt rose.dat ve stejnem adresari jako dany soubor!');
writeln;writeln;
writeln('Stisknete klavesu');
repeat until keypressed;
halt;
end;
fsize:=filesize(f);
getmem(font,fsize);
BlockRead(f,Font^,FileSize(F));
Close(f);
reset(f,1);
blockread(f,height,sizeof(height));
close(f);
randomize;
SetMCGA;
intro;
repeat
waitretrace;
cls(0,VGA);
ZobrazHLm;
case HLmenu of
start : Game;
credit: JaJenJA;
konci : konec:=true;
end;
until konec;
settext;
freemem(font,fsize);
end.