{ 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; var virt:pvirt; {virtulani obrazovka} vaddr:word; {segment nasi virtualni obrazovky} Zwall:pZwall; Awall:pAwall; {nase zidka 64x64} Bwall:pBwall; Cwall:pCwall; ASwall:pASwall; {jen ASwall ma odlisne rozmery} BSwall:pBwall; CSwall:pCwall; palPCX:Tpal; {zde ulozime paletu PCX souboru} map:Tmap; {mapa dungeonu} player:Tplayer; procedure setVGA; assembler; {nastaveni VGA modu 320x200x256} asm mov ax, 13h int 10h end; procedure settext; assembler; {navrat zpet do textoveho modu} asm mov ax, 03h int 10h end; procedure putpixel(x,y: word; c:byte; where:word); assembler; {tato procedura co nejrychleji umisti pixel na misto v pameti se segmentem where} asm mov ax, [where] mov es, ax mov bx, [x] mov dx, [y] mov di, bx mov bx, dx shl dx, 8 shl bx, 6 add dx, bx add di, dx mov al, [c] mov es:[di], al 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 konec; {uvolneni pameti} begin freemem(virt, 64000); freemem(Awall, Amax); freemem(Bwall, Bmax); freemem(Cwall, Cmax); freemem(ASwall,ASmax); freemem(BSwall,Bmax); freemem(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 nactiImages; {zkonvertuje vsechny potrebne obrazky zdi z puvodni Zwall} begin getmem(Zwall,Zmax); nactiPCX; ZtoA; AtoB; BtoC; ZtoAS; AtoBS; BtoCS; freemem(Zwall,Zmax); 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.