Demonštrační program na téma 3D DUNGEON

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Category: KMP (Club of young programmers)
wall.pngAuthor: Aleš Kucik
web: www.webpark.cz/prog-pascal

Program: Dungeon.pas
File exe: Dungeon.exe
need: Wall.pcx

Demonštrační program na téma 3D DUNGEON
  • tento program by měl jednoduše nastíniť techniku, jak vykreslit nejaký 3D pohled
  • nedostatkem je špatná orientace v takovem dungeonu, protože se můžete otočit jen po 90 stupních
  • další nedostatek mnou použité metódy zobrazení objevíte, když se postavíte proti zdi rohu tak, že byste měli částečne po strane videt do chodby, po stranách se neobjevi zdi (a nebo jen kousek), i když by měly treba pokračovat. Ale tento nedostatek by měl jít odstranit.
Vysvetlivky: zdi jsou deleny na Z, A, B, C (od největší po nejmenší) postupne s poloviční délkou strany než predešlá napr. BSwall znamená - B Side wall - postranní zed velikosti B
{ 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.