(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(*  Soubor: DYNPOLE.PAS                                                    *)
(*  Obsah: procedury na vytvoreni, zruseni a obsluhu dvojrozmerneho dyna-  *)
(*         mickeho pole a demonstracni program                             *)
(*  Autor: Mircosoft                                                       *)
(*  Posledni uprava: 20.9.2004                                             *)
(*  Pro kompilaci: (CRT)                                                   *)
(*  Pro spusteni: nic                                                      *)
(*  Upozorneni: tyto zdrojove kody pouzivate na vlastni nebezpeci          *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
program DynamickePole;
uses crt;{kvuli clrscr}

type
uk = ^policko;
policko = record
          hodnota:byte;
          l,p,h,d:uk;{ukazatele na policka vLevo, vPravo, naHore a Dole}
          end;

function Vytvor(velikostX,velikostY:word):uk;
{Zadejte sirku a vysku pole, funkce ho vytvori a vrati ukazatel na levy horni
roh}
var i:word;{pro For cykly}
    prvni,{ukazatel na leve horni policko}
    pom,{pomocny ukazatel}
    novy:uk;{ukazatel na prave vytvorene policko}
Begin
{kdyz je velikost rovna 0, tak se nic vytvaret nebude:}
if (velikostx=0)or(velikosty=0) then begin
                                     vytvor:=nil;
                                     exit;
                                     end;
{levy horni roh:}
new(prvni);
with prvni^ do begin
               l:=nil; p:=nil; h:=nil; d:=nil;{zatim neni na co ukazovat}
               hodnota:=0;
               end;
{prvni radek:}
pom:=prvni;
if velikostX>1 then{pokud jsou aspon dva sloupce}
 for i:=2 to velikostX do begin
                          new(novy);{nove policko}
                          with novy^ do begin
                                        hodnota:=0;
                                        p:=nil; h:=nil; d:=nil;{tady jeste nic neni}
                                        l:=pom;{propojeni s polickem vlevo}
                                        end;
                          pom^.p:=novy;{propojeni leveho policka s novym}
                          pom:=novy;{o policko doprava}
                          end;
{prvni sloupec:}
pom:=prvni;
if velikostY>1 then{pokud jsou aspon dva radky}
 for i:=2 to velikostY do begin
                          new(novy);{nove policko}
                          with novy^ do begin
                                        hodnota:=0;
                                        l:=nil; p:=nil; d:=nil;{tady jeste nic neni}
                                        h:=pom;{propojeni s polickem nahore}
                                        end;
                          pom^.d:=novy;{propojeni horniho policka s novym}
                          pom:=novy;{o policko dolu}
                          end;
{vyplneni zbyleho prostoru:}
pom:=prvni;
while pom^.d<>nil do{dokud nejsme na poslednim radku...}
  begin
  while pom^.p<>nil do{...ani na poslednim sloupci:}
    begin
    new(novy);{nove policko}
    with novy^ do begin
                  p:=nil; d:=nil;{vpravo ani dole nic neni}
                  hodnota:=0;
                  l:=pom^.d; h:=pom^.p;{napojeni vlevo a nahore}
                  end;
    pom^.d^.p:=novy; pom^.p^.d:=novy;{napojeni leveho a horniho policka}
    pom:=pom^.p;{o policko doprava}
    end;
  while pom^.l<>nil do pom:=pom^.l;{na zacatek radku}
  pom:=pom^.d;{o radek dal (dolu)}
  end;
vytvor:=prvni;
End;{vytvor}

procedure Zrus(var lh:uk);
{staci zadat ukazatel na levy horni roh (tj. hodnotu, kterou vraci funkce
Vytvor) a pole se cele zrusi.}
var pom:uk;
    i:word;{pomocna, aby se vedelo, kdy prestat}
Begin
if lh<>nil then
 repeat
 pom:=lh;{pom nastavime na levy horni roh}
 i:=0;
 while pom^.p<>nil do begin
                      pom:=pom^.p;{posuneme ho co nejvic doprava...}
                      inc(i);
                      end;
 while pom^.d<>nil do begin
                      pom:=pom^.d;{...a co nejvic dolu}
                      inc(i);
                      end;
 if pom^.l<>nil then pom^.l^.p:=nil;
 if pom^.h<>nil then pom^.h^.d:=nil;{odpojime ukazatele, ktere na nej ukazuji...}
 dispose(pom);{...a policko vymazeme}
 until i=0;{a to cele delame tak dlouho, dokud je co mazat}
lh:=nil;
End;{zrus}

function Get(LH:uk;x,y:word):uk;
{vraci ukazatel na policko o souradnicich x a y, LH je levy horni roh pole}
var i:word;{pro For cyklus}
    pom:uk;{pomocny ukazatel}
Begin
pom:=lh;
if x>1 then{pokud hledame policko v prvnim sloupci, nikam se posunovat nebudeme}
 for i:=2 to x do
  if pom^.p<>nil{pokud je kam se posunout...}
   then pom:=pom^.p;{... posuneme se o policko doprava}
if y>1 then for i:=2 to y do if pom^.d<>nil then pom:=pom^.d;{a to same pro y-ovou souradnici}
get:=pom;
End;{get}

procedure pisznak(x,y:byte;zn:char;bt,bp:byte);
{jen pomocna procedura na vykresleni znaku na obrazovku - abych se nemusel
patlat s Textcolor a Write. X je 0..79, Y je 0..24, nepokousejte se dat vic,
protoze pak se muze v pameti prepsat neco duleziteho.
Stejna procedura je v jednotce TEXTY.PAS}
var obrazovka:array[0..3999] of byte absolute $B800:0000;{obrazova pamet}
Begin
obrazovka[(x+80*y)shl 1]:=ord(zn); {neco shl 1 = neco*2, ale je to rychlejsi}
obrazovka[((x+80*y)shl 1)+1]:=bt or (bp shl 4); {bp shl 4 = bp*16}
End;{pisznak}

var pole:uk;{ukazatel na levy horni roh pole}
    sirka,vyska:word;{rozmery pole}
    x,y:word;{pomocne, pro for cyklus}
    u:uk;{pomocny ukazatel}
    ch:char;{pro zadani ano/ne}
BEGIN
clrscr;
writeln('Toto je demonstracni program na vyzkouseni 2D dynamickeho pole.');
writeln(' Pokracujte Enterem...');
readln;
repeat
clrscr;
writeln('Zadejte rozmery pole,');
write('sirka (ne vic nez 78, prosim): '); readln(sirka);
write('vyska (ne vic nez 24, prosim): '); readln(vyska);
if sirka>78 then sirka:=78; if vyska>24 then vyska:=24;{ne ze bych uzivateli neveril, ale jistota je jistota :-) }
write(' Dekuji, vytvarim pole...');
Pole:=Vytvor(sirka,vyska);
writeln(' Hotovo.');
writeln('Ukazatel Pole ted ukazuje na levy horni roh pole o rozmerech ',sirka,'x',vyska);
writeln('Pro pokracovani stisknete Enter.');
readln;
writeln('Ted se pole naplni cisly. V kazdem policku bude soucet jeho x-ove a y-ove souradnice.');
writeln('Stiskni Enter pro pokracovani.');
readln;
write('Generuji obsah pole...');
for x:=1 to sirka do
 for y:=1 to vyska do
  begin
  u:=get(pole,x,y);
  u^.hodnota:=x+y;
  end;
writeln(' Hotovo.');
writeln('Jednotliva policka ted obsahuji ruzna cisla.');
writeln('Ted se pole barevne vykresli, pro pokracovani stiskni Enter.');
readln;
clrscr;
for x:=1 to sirka do
 for y:=1 to vyska do begin
                      u:=get(pole,x,y);
                      pisznak(x,y,#0,u^.hodnota and 15,0);
                      end;
gotoxy(1,25);
write('Pro pokracovani Enter.');
readln;
clrscr;
writeln('Ted se pole smaze. Prosim Enter...');
readln;
write('Mazu pole...');
Zrus(Pole);
writeln('Pole zruseno.');
writeln;
write('Chcete si to vyzkouset znovu? (A/N)');
readln(ch);
until upcase(ch)<>'A';
clrscr;
writeln('Program by Mircosoft (c) 2004');
END.