Umiestnenie súboru www.TrSek.com/cover/ales/dungeon.pas{ DUNGEON.PAS Copyright (c) Ales Kucik }
{ Demonstracni program na tema 3D DUNGEON }
{ }
{ - tento program by mel jednoduse nastinit techniku, jak }
{ vykreslit nejaky 3D pohled }
{ - nedostatkem je spatna orientace v takovem dungeonu, }
{ protoze se muzete otocit jen po 90 stupnich }
{ - dalsi nedostatek mnou pouzite metody zobrazeni objevite, }
{ kdyz se postavite proti zdi rohu tak, ze byste meli }
{ castecne po strane videt do chodby, po stranach se }
{ neobjevi zdi (a nebo jen kousek), idyz by mely treba }
{ pokracovat. Ale tento nedostatek by mel jit odstranit. }
{ }
{ Vysvetlivky: }
{ zdi jsou deleny na Z, A, B, C (od nejvetsi po nejmensi) }
{ postupne s polovicni delkou strany nez predesla }
{ }
{ napr. BSwall znamena - B Side wall - postranni zed velikosti B }
{ }
{ Datum:29.11.2002 http://www.trsek.com }
program Dungeon3D;
{$G+}
uses Crt;
const
VGA = $a000; {segment pameti VGA}
Zlength = 128; {delky strany zdi Z, A, B,C}
Alength = 64;
Blength = 32;
Clength = 16;
Zmax= 16384; {veliost zakladniho obrazku 128x128 = 16384}
Amax= 4096;
Bmax= 1024;
Cmax= 256;
ASmax=8192; {velikost postranni zdi velikosti A (128*64)}
maxMap=21; {velikost strany pole obsahujiciho mapu DUNGEONU}
GameOver:boolean = false; {prednastavena promenna pro ukonceni programu}
type
Tvirt = array [1..64000] of byte; {pole velikosti nasi obrazovky (320x200)}
Pvirt = ^Tvirt; {ukazatel na virtualni obrazovku}
TAwall = array [1..Amax] of byte; {nase zed bude mit rozmery 64x64=4096}
PAwall = ^TAwall; {ukazatel na nasi zidku}
TBwall = array [1..Bmax] of byte;
PBwall = ^TBwall;
TCwall = array [1..Cmax] of byte;
PCwall = ^TCwall;
TZwall = array [1..Zmax] of byte;
PZwall = ^TZwall;
TASwall = array [1..ASmax] of byte;
PASwall = ^TASwall;
{ASwall bude dvojnasobne siroka aby zakrila celou A zed}
Tdirection = (No, Ea, So, We);
Tcase = (nothing, wall, corner);
Tmap = array [1..maxMap,1..maxMap] of Tcase;
Tpal = array [0..255, 1..3] of byte;
Tplayer = record
x,y:byte;
direc:Tdirection;
end;
procedure cls(where:word; c:byte); assembler;
{naplni pamet danou segmentem where urcitou barvou}
asm
mov cx, 32000
mov es, [where]
xor di, di
mov al, [c]
mov ah, al
rep stosw
end;
procedure flip(source, dest:word); assembler;
{misto pameti se seg. dest se naplni obsahem pameti se seg. source}
asm
push ds
mov cx, 32000
mov es, [dest]
mov ds, [source]
xor si, si
xor di, di
rep movsw
pop ds
end;
procedure setpal(colorNo,r,g,b:byte);
{zde je neco pro nastaveni palety}
begin
port[$3c8]:=colorNo;
port[$3c9]:=r;
port[$3c9]:=g;
port[$3c9]:=b;
end;
procedure getpal(colorNo:byte; var r,g,b:byte);
{pomoci teto procedury si muzeme uchovat starou paletu}
begin
port[$3c7]:=colorNo;
r:=port[$3c9];
g:=port[$3c9];
b:=port[$3c9];
end;
procedure setPCXpal;
{nastavy na VGA karte paletu naseho PCX souboru}
var i:byte;
begin
for i:= 0 to 255 do setpal(i, palPCX[i,1] shr 2, palPCX[i,2] shr 2,
palPCX[i,3] shr 2); {vsechny hodnoty palPCX se musi vydelit 4, aby
byly v intervalu 0..63}
end;
procedure WaitRetrace; assembler;
{ceka se, az se bude elektronovy paprsek obrazovky vracet do
horniho leveho rohu - nebude se nam na obrazovce obevovat nechutne
blikani}
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 inicializace;
{zaberem si kus pameti pro nasi virtualni obrazovku a
zjistime si jeji segment, ktery ulozim v vaddr}
begin
randomize;
getmem(virt, 64000);
vaddr:= seg (virt^);
getmem(Awall, Amax); {pamet pro nasi zidku}
getmem(Bwall, Bmax);
getmem(Cwall, Cmax);
getmem(ASwall, ASmax);
getmem(BSwall, Bmax);
getmem(CSwall, Cmax);
end;
procedure ramecek(x1,y1,x2,y2:word; c:byte; where:word);
{neni to zrovna nejrychlejsi, ale budeme ho kreslit asi jen jednou}
var
i:word;
begin
for i:=x1 to x2 do
begin
putpixel(i, y1, c, where);
putpixel(i, y2, c, where);
end;
for i:=y1 to y2 do
begin
putpixel(x1, i, c, where);
putpixel(x2, i, c, where);
end;
end;
procedure nactiPCX;
{nacte soubor wall.PCX kde je ulozen obrazek zdi}
var
soubor:file;
data:byte;
index:word;
skupina:byte;
begin
skupina:=0; {obsahuje delku rady stejnych pixelu}
index:=1; {obsahuje nasi pozici v obrazku zdi}
assign(soubor, 'wall.pcx');
{soubor obrazku zdi wall.pcx musi byt v aktualnim adresari}
{$I-} {jen pro jistotu}
reset(soubor,1); {data budeme prenaset po jednom byte}
{$I+}
if IOresult <> 0 then
begin
writeln('Nenalezl jsem soubor s obrazkem zdi!');
writeln('Prosim umistete soubor WALL.PCX do adresare, kde se');
writeln('nachazi tento program');
konec;
halt;
end;
{Pokud jsme jeste tady, tak byl soubor nalezen :o) }
seek(soubor, 128);
{preskocili jsme hlavicku ktera ma 128 bytu, predpokladam totiz, ze
byl nalezen ten spravny soubor a ze ma spravny tva i velikost}
{nyni si ulozime do pameti obrazek jako pole delky 16384 (128x128)}
repeat
blockread(soubor, data, 1);
{kdyz jsou data>=$C0 (dekadicky 192 = 1100 0000 - horni dva bity jsou
nastaveny), pak se v dolnich 4 bitech naleza delka skupinky pixelu
stejne barvy a nasledujici byte souboru je barva techto pixelu}
if data >= 192 then
begin
skupina:=data and 63;
{63 = 0000 1111b ve "skupina" zbudou jen dolni 4 bity=delka skupinky}
blockread(soubor, data, 1); {prectu barvu}
repeat
Zwall^[index]:= data;
inc(index);
dec(skupina);
until skupina = 0;
end
else
begin
Zwall^[index]:=data;
inc(index);
end;
until index >Zmax; {pamatujte, nas obrazek zdi ma 128x128 pixelu}
blockread(soubor, data, 1);
{nyni kontrola jestli jsme uz u palety souboru PCX}
if data <> 12 then
begin
writeln('Shit neco se posralo jako vzdy');
freemem(Zwall,Zmax);
konec;
writeln('PCX ma pravdepodobne nespravne rozmery');
halt;
end
else blockread(soubor, palPCX, 768);
{nebudem se stim babrat, takhle jsme nacetli celou paletu PCX souboru
do promenne palPCX (chapete to ne? 3 slozky barvy - RGB x 256 barev
palety = 768 (bytu) - pred pouzitim je bude treba vydelit 4}
close(soubor);
end; {nyni mame obrazek nacten v pameti, to lehci je za nama}
procedure zobrazAImage(x,y:word);
{zobrazi predni A zed na urcene souradnice}
var
i,j:byte;
begin
for i:=1 to Alength do
for j:=1 to Alength do
if Awall^[(i-1)*Alength+j]<>0 then
putpixel(j+x-1, i+y-1, Awall^[(i-1)*Alength+j], vaddr);
end;
procedure zobrazBImage(x,y:word); {stejne jako zobrzAImage}
var
i,j:byte;
begin
for i:=1 to Blength do
for j:=1 to Blength do
if Bwall^[(i-1)*Blength+j]<>0 then
putpixel(j+x-1, i+y-1, Bwall^[(i-1)*Blength+j], vaddr);
end;
procedure zobrazCImage(x,y:word);
var
i,j:byte;
begin
for i:=1 to Clength do
for j:=1 to Clength do
if Cwall^[(i-1)*Clength+j]<>0 then
putpixel(j+x-1, i+y-1, Cwall^[(i-1)*Clength+j], vaddr);
end;
procedure zobrazLASImage(x,y:word);
{zobrazi upraveny obrazek postranni zdi takovim zpusobem, ze vypada
jako by leva proto LAS = Left A Side - A postranni zed se lisi je
tim, ze ma dvojnasobnou sirku nez ostatni(B,C)}
var
i,j:byte;
begin
for i:=1 to Alength do
for j:=1 to Zlength do
if ASwall^[Alength*(j-1)+i]<>0 then
putpixel(i+x-1, j+y-1, ASwall^[Alength*(j-1)+i], vaddr);
end;
procedure zobrazLBSImage(x,y:word); {viz zobrazLASImage}
var
i,j,z:byte;
begin
z:= Blength div 2;
for i:=1 to z do
for j:=1 to Alength do
if BSwall^[z*(j-1)+i]<>0 then
putpixel(i+x-1, j+y-1, BSwall^[z*(j-1)+i], vaddr);
end;
procedure zobrazLCSImage(x,y:word);
var
i,j,z:byte;
begin
z:= Clength div 2;
for i:=1 to z do
for j:=1 to Blength do
if CSwall^[z*(j-1)+i]<>0 then
putpixel(i+x-1, j+y-1, CSwall^[(j-1)*z+i], vaddr);
end;
procedure zobrazRASImage(x,y:word);
{zobrazi postranni zed z praveho pohledu}
var
i,j:byte;
begin
for i:=1 to Alength do
for j:=1 to Zlength do
if ASwall^[Alength*(j-1)+Alength-i+1]<>0 then
putpixel(i+x-1, j+y-1, ASwall^[Alength*(j-1)+Alength-i+1], vaddr);
end;
procedure zobrazRBSImage(x,y:word);
var
i,j,z:byte;
begin
z:= Blength div 2;
for i:=1 to z do
for j:=1 to Alength do
if BSwall^[z*(j-1)+z-i+1]<>0 then
putpixel(i+x-1, j+y-1, BSwall^[z*(j-1)+z-i+1], vaddr);
end;
procedure zobrazRCSImage(x,y:word);
var
i,j,z:byte;
begin
z:= Clength div 2;
for i:=1 to z do
for j:=1 to Blength do
if CSwall^[z*(j-1)+z-i+1]<>0 then
putpixel(i+x-1, j+y-1, CSwall^[(j-1)*z+z-i+1], vaddr);
end;
procedure ZtoA;
{prevod obrazku o rozmerech 128x128(velikost Z) na 64x64(velikost A)
tak ze bude vynechan kazdy druhy pixel}
var
i,j:byte;
begin
for i:=1 to Alength do
for j:=1 to Alength do
Awall^[(i-1)*Alength+j]:=Zwall^[(2*i-1)*Zlength+2*j];
end;
procedure AtoB;
{podobne jako ZtoA}
var
i,j:byte;
begin
for i:=1 to Blength do
for j:=1 to Blength do
Bwall^[(i-1)*Blength+j]:=Awall^[(2*i-1)*Alength+2*j];
end;
procedure BtoC;
var
i,j:byte;
begin
for i:=1 to Clength do
for j:=1 to Clength do
Cwall^[(i-1)*Clength+j]:=Bwall^[(2*i-1)*Blength+2*j];
end;
procedure ZtoAS;
{z obrazku Zwall udela AS wall (postranni zed A) tak, ze se
odsekne orni a dolni cast, asi nejak takto
______
I\ I
I \ I <------------ tyto "trojuhelnicky budou odstraneny
I \ I I
I \ I /
I \I /
I I /
I I /
I I /
I I /
I I /
I /I /
I / I /
I / I <-/
I / I
I/____I
tato technika se ponekud lisi od te z GDM4, kde byl obrazek natahovan
do pozadovaneho tvaru
jak uz jsem rekl AS ma trochu nestandartni rozmery}
var
a:word;
i,j,z:byte;
begin
for a:=1 to ASmax do ASwall^[a]:=0;
for i:=1 to Alength div 2 do
for j:=i to Zlength-i do
begin
ASwall^[(j-1)*Alength+2*i-1]:=Zwall^[i*4-1+(j-1)*Zlength];
ASwall^[(j-1)*Alength+2*i ]:=Zwall^[i*4 +(j-1)*Zlength];
end;
end;
procedure AtoBS;
var
a:word;
i,j,y:byte;
begin
for a:=1 to Bmax do BSwall^[a]:=0;
y:= Blength div 2;
for i:=1 to y do
for j:=i to Alength-i do
BSwall^[(j-1)*y+i]:=Awall^[i*4+(j-1)*Alength];
end;
procedure BtoCS;
var
a:word;
i,j,y:byte;
begin
for a:=1 to Cmax do CSwall^[a]:=0;
y:= Clength div 2;
for i:=1 to y do
for j:=i to Blength-i do
CSwall^[(j-1)*y+i]:=Bwall^[i*4+(j-1)*Blength];
end;
procedure makeMap;
{Tato procedura 'postavi' nas DUNGEON}
var
i,j:byte;
xroh,sum:word;
direc:Tdirection;
function rohu (mX,mY:byte):word;
var
loop1,loop2:byte;
temp:word;
begin
temp:=0;
for loop1:=1 to mX do
for loop2:=1 to mY do
if map[loop1,loop2]=corner then inc(temp);
rohu:= temp;
end;
procedure kudykam(xx,yy:byte; xsmer:tdirection);
var
k,num:byte;
begin
k:=0;
case xsmer of
No:repeat
map[xx,yy-k]:=wall;
inc(k);
until map[xx,yy-k]=wall;
So:repeat
map[xx,yy+k]:=wall;
inc(k);
until map[xx,yy+k]=wall;
We:repeat
map[xx-k,yy]:=wall;
inc(k);
until map[xx-k,yy]=wall;
Ea:repeat
map[xx+k,yy]:=wall;
inc(k);
until map[xx+k,yy]=wall;
end;
end;
begin
for i:=1 to maxMap do
for j:=1 to maxMap do
if (odd(i)) and (odd(j)) then map[i,j]:= corner
else map[i,j]:= nothing;
for i:=1 to maxMap do {kolem mapy bude 3 policka siroka hranice}
begin
map[i, 1]:=wall;
map[i, 2]:=wall;
map[i, 3]:=wall;
map[i, maxMap ]:=wall;
map[i, maxMap-1]:=wall;
map[i, maxMap-2]:=wall;
end;
for i:=1 to maxMap do
begin
map[1, i]:=wall;
map[2, i]:=wall;
map[3, i]:=wall;
map[maxMap , i]:=wall;
map[maxMap-1, i]:=wall;
map[maxMap-2, i]:=wall;
end;
repeat
xroh:= random(rohu(maxMap,maxMap))+1;
sum:=0;
for i:=1 to maxMap do
for j:=1 to maxMap do
begin
if map[i,j]=corner then
begin
inc(sum);
if sum = xroh then
begin
case random(4) of
0: direc:=We;
1: direc:=So;
2: direc:=Ea;
3: direc:=No;
end;
kudykam(i,j,direc);
end;
end;
end;
until rohu(maxMap,maxMap) = 0;
end;
procedure zobrazScenu;
{tato procedura vykresli do virtualni obrazovky nas pohled,
podle pozice hrace (player.x a player.y) a smeru jeho pohledu
(player.direc)}
var i:byte;
begin
with player do
case player.direc of
No:
begin
for i:=0 to 6 do
if map[x+i-3, y-3]=wall then zobrazCImage(104+i*Clength,92);
for i:=0 to 1 do
begin
if map[x+i-2, y-2]=wall then
begin
zobrazBImage(80+i*Blength,84);
zobrazLCSImage(112+i*Blength,84);
end;
if map[x+2-i, y-2]=wall then
begin
zobrazBImage(240-(i+1)*Blength,84);
zobrazRCSImage(232-(i+1)*Blength,84);
end;
end;
if map[x,y-2]=wall then zobrazBImage(144,84);
if map[x-1, y-1]=wall then
begin
zobrazAImage(64,68);
zobrazLBSImage(128,68);
end;
if map[x+1, y-1]=wall then
begin
zobrazAImage(192,68);
zobrazRBSImage(176,68);
end;
if map[x,y-1]=wall then zobrazAImage(128,68);
if map[x-1,y]=wall then zobrazLASImage(64,36);
if map[x+1,y]=wall then zobrazRASImage(192,36);
end;
So:
begin
for i:=0 to 6 do
if map[x+3-i, y+3]=wall then zobrazCImage(104+i*Clength,92);
for i:=0 to 1 do
begin
if map[x+2-i, y+2]=wall then
begin
zobrazBImage(80+i*Blength,84);
zobrazLCSImage(112+i*Blength,84);
end;
if map[x+i-2, y+2]=wall then
begin
zobrazBImage(240-(i+1)*Blength,84);
zobrazRCSImage(232-(i+1)*Blength,84);
end;
end;
if map[x,y+2]=wall then zobrazBImage(144,84);
if map[x+1, y+1]=wall then
begin
zobrazAImage(64,68);
zobrazLBSImage(128,68);
end;
if map[x-1, y+1]=wall then
begin
zobrazAImage(192,68);
zobrazRBSImage(176,68);
end;
if map[x,y+1]=wall then zobrazAimage(128,68);
if map[x+1,y]=wall then zobrazLASImage(64,36);
if map[x-1,y]=wall then zobrazRASImage(192,36);
end;
Ea:
begin
for i:=0 to 6 do
if map[x+3, y+i-3]=wall then zobrazCImage(104+i*Clength,92);
for i:=0 to 1 do
begin
if map[x+2, y+i-2]=wall then
begin
zobrazBImage(80+i*Blength,84);
zobrazLCSImage(112+i*Blength,84);
end;
if map[x+2, y+2-i]=wall then
begin
zobrazBImage(240-(i+1)*Blength,84);
zobrazRCSImage(232-(i+1)*Blength,84);
end;
end;
if map[x+2,y]=wall then zobrazBImage(144,84);
if map[x+1, y-1]=wall then
begin
zobrazAImage(64,68);
zobrazLBSImage(128,68);
end;
if map[x+1, y+1]=wall then
begin
zobrazAImage(192,68);
zobrazRBSImage(176,68);
end;
if map[x+1,y]=wall then zobrazAimage(128,68);
if map[x,y-1]=wall then zobrazLASImage(64,36);
if map[x,y+1]=wall then zobrazRASImage(192,36);
end;
We:
begin
for i:=0 to 6 do
if map[x-3, y+3-i]=wall then zobrazCImage(104+i*Clength,92);
for i:=0 to 1 do
begin
if map[x-2, y+2-i]=wall then
begin
zobrazBImage(80+i*Blength,84);
zobrazLCSImage(112+i*Blength,84);
end;
if map[x-2, y-2+i]=wall then
begin
zobrazBImage(240-(i+1)*Blength,84);
zobrazRCSImage(232-(i+1)*Blength,84);
end;
end;
if map[x-2, y]=wall then zobrazBImage(144,84);
if map[x-1, y+1]=wall then
begin
zobrazAImage(64,68);
zobrazLBSImage(128,68);
end;
if map[x-1, y-1]=wall then
begin
zobrazAImage(192,68);
zobrazRBSImage(176,68);
end;
if map[x-1,y]=wall then zobrazAimage(128,68);
if map[x,y+1]=wall then zobrazLASImage(64,36);
if map[x,y-1]=wall then zobrazRASImage(192,36);
end;
end;
end;
function GetKey:word;
{ceka na stisknuti klavesy a vraci jeji cislo}
var a:word;
begin
a:=ord(readkey);
if a=0 then a:=256+ord(readkey);
getKey:=a;
end;
{HLAVNI PROGRAM}
var
i,j:byte;
begin
writeln('Vitam vas v mem ukazkovem programu pro clanek o 3D-DUNGEONU z GDM4!');
writeln;writeln;
writeln('program se ukonci klavesou ESC');
writeln('muzete se pohybovat pomoci sipek');
writeln;writeln;writeln;
writeln('Neco stiskni');
getkey;
writeln('Drzte se jizda zacina!');
inicializace; {alokujem pamet}
nactiImages; {nactem obrazky}
setVGA; {nastavime mod 13h}
setPCXpal; {nastavime paletu PCX souboru}
makeMap; {postavime plan dungeonu}
with player do {nastavime pozici hrace}
begin
x:=10;
y:=10;
direc:=We;
end;
repeat
cls(vaddr,0); {vymazem virtualni obrazovku}
ramecek(63,36,256,164,3,vaddr); {nakreslime ramecek pruhledu}
zobrazScenu; {zobrazime 3D scenu}
waitretrace; {chvilku pockame, aby to neblikalo}
flip(vaddr,VGA); {zkopirujem virtualni obrazovku, do videopameti}
delay(50); {chvilku pockame, aby jsme nebehali moc rychle}
with player do
begin
case getKey of {ceka se na stisk klavesy}
27: GameOver:=true;
328: {jdeme dopredu - sipka nahoru}
case direc of
No: if map[x,pred(y)]<>wall then dec(y);
So: if map[x,succ(y)]<>wall then inc(y);
Ea: if map[succ(x),y]<>wall then inc(x);
We: if map[pred(x),y]<>wall then dec(x);
end;
336: {jdeme dozadu - sipka dolu}
case player.direc of
No: if map[x,succ(y)]<>wall then inc(y);
So: if map[x,pred(y)]<>wall then dec(y);
Ea: if map[pred(x),y]<>wall then dec(x);
We: if map[succ(x),y]<>wall then inc(x);
end;
333: {tocime se doprava - prava sipka}
if direc=We then direc:=No
else direc:=succ(direc);
331: {tocime se doleva - leva sipka}
if direc=No then direc:=We
else direc:=pred(direc);
end;
end;
until GameOver;
settext; {navrat do textoveho modu}
konec; {uvolneni pameti}
end.