Unit CPLX;
{Jedna z moznosti, jak pracovat s komplexnimi cisly
Musite ji ale ulozit pod nazvem CPLX.pas ve spravnem adresari -
bud v adresari units, nebo v adresari s programem, ve kterem tuto jednotku vyuzivate}

Interface
type Komplex = record
                Re : Real;
                Im : Real;
               end;

procedure Vypis(A:Komplex); {Vypise komplexni cislo na obrazovku}
{Tohle by bylo lepsi udelat jak funkci, ktera pouze vraci prislusny
string, zvladnete to prepsat?}

function Absolutni(A:Komplex):Real; {Absolutni hodnota komplexniho cisla}
function Argument(A:Komplex):Real;  {Argument komplexniho cisla}
function Re(A:Komplex):Real;        {Realna cast komplexniho cisla}
function Im(A:Komplex):Real;        {Imaginarni cast komplexniho cisla}

function JeJedna(A:Komplex):Boolean;{Je komplexni cislo komplexni jednotkou?}

procedure Scitej(A,B:Komplex;var Vysledek:Komplex); {A+B}
procedure Odcitej(A,B:Komplex;var Vysledek:Komplex);{A-B}
procedure Nasob(A,B:Komplex;var Vysledek:Komplex);  {A*B}
procedure Del(A,B:Komplex;var Vysledek:Komplex);    {A/B}

procedure MocniNaN(A:Komplex;B:Integer;var Vysledek:Komplex);{Umocni komplexni cislo na cislo prirozene}
procedure MocniNaR(A:Komplex;B:Real;var Vysledek:Komplex); {Umocni komplexni cislo na cislo realne}

procedure Mocni(A,B:Komplex;var Vysledek:Komplex); {A^B}
procedure Odmocni(A,B:Komplex;var Vysledek:Komplex); {Vyhleda ovsem pouze jedinou odmocninu}

Implementation
const presnost=0.0000001; {Jak male cislo jeste rozlisujeme od nuly}

Procedure Vypis; {Prehlednejsi by bylo znovu opsat celou hlavicku, at vime, co mame za promenne}
Begin
 writeln(A.Re ,' + ',A.Im, 'i');
End;

Function Absolutni;
Begin
 Absolutni:=Sqrt(Sqr(A.Re)+Sqr(A.Im));
End;

Function Argument;
var P : Real;
Begin
 if A.Re<>0 then P:=ArcTan(A.Im/A.Re)
  else
   if A.Im <0 then P:=3*Pi/2
    else P:=Pi/2; {I v pripade, ze A = 0, coz neni zcela spravne, ale aspon to nehaze chybu}
 if (A.Re > 0) and (A.Im < 0) then P:=P+2*Pi;
 if A.Re < 0 then P:=P+Pi;
 Argument:=P;
End;

Function Re;
Begin
 Re:=A.Re;
End;

Function Im;
Begin
 Im:=A.Im;
End;

Function JeJedna;
Begin
 if Abs((Absolutni(A)-1))<presnost then JeJedna:=true else JeJedna:=false;
end;

Procedure Scitej;
Begin
 Vysledek.Re:=A.Re+B.Re;
 Vysledek.Im:=A.Im+B.Im;
End;

Procedure Odcitej;
Begin
 Vysledek.Re:=A.Re-B.Re;
 Vysledek.Im:=A.Im-B.Im;
End;

Procedure Nasob;
Begin
 Vysledek.Re:=A.Re*B.Re-A.Im*B.Im;
 Vysledek.Im:=A.Im*B.Re+A.Re*B.Im;
End;

Procedure Del;
var P : Real;
Begin
 P:=Sqr(B.Re)+Sqr(B.Im);
 if P = 0 then RunError(200); {Deleni nulou, nebudeme osetrovat jinak}
 Vysledek.Re:=A.Re*B.Re+A.Im*B.Im;
 Vysledek.Im:=A.Im*B.Re-A.Re*B.Im;
 Vysledek.Re:=Vysledek.Re/P;
 Vysledek.Im:=Vysledek.Im/P;
end;

Procedure MocniNaN;   {Sprostym nasobenim}
var I: Integer;
Begin
 Vysledek.Re:=1;
 Vysledek.Im:=0;
 For I:=1 to B do             {Rekurze by mohla rychle preteci}
  Nasob(Vysledek,A,Vysledek);
End;


Procedure MocniNaR;  {Vyuzijeme Moivrovu vetu}
var Z,R: Real;
    AV : Real; {Absolutni hodnota vysledku}
Begin
 Z:=Absolutni(A);
 R:=Argument(A);
 AV:=Exp(B*Ln(Z));
 Vysledek.Re:=AV*Cos(B*R);
 Vysledek.Im:=AV*Sin(B*R);
End;

Procedure Mocni;
{Tak tohle uz je skutecny orisek, vyuzijeme e ^ ix = cos x + i sin x a vlastnosti logaritmu,
nesmime zapomenout osetrit nuly}
var Z,Fi:Real; {Absolutni hodnota a argument u A}
    X,Y  :Real; {Pomocne promenne}
    C,D  :Real;
begin
 Z:=Absolutni(A);
 Fi:=Argument(A);
 C:=B.Re;
 D:=B.Im;

 if (Abs(B.Re) <presnost) and (Abs(B.Im)<presnost) then
  begin
   Vysledek.Re:=1;
   Vysledek.Im:=0; {Cokoliv na nultou je jedna - sice to neni uplne spravne, ale co}
   Exit; {Vysledek uz mame, co otravovat dalsimi vypocty, ktere by jeste mohly ovlivnit vysledek}
  end;

 if (Abs(A.Re) <presnost) and (Abs(A.Im)<presnost) then {Kvuli zaokrouhlovani je to lepsi takhle}
  begin
   if (B.Re>0) and (Abs(A.Im)<presnost) then
    begin
     Vysledek.Re:=0;
     Vysledek.Im:=0; {Nula na cokoliv kladneho je porad nula}
    end
     else
    RunError(200); {Tahle operace totiz az nebezpecne pripomina deleni nulou}
   Exit; {Vysledek uz preci mame, neni treba dale zdrzovat}
  end;

 X:=Exp(Ln(Z)*C)*Exp(-D*Fi);
 Y:=Fi*C+D*Ln(Z);

 Vysledek.Re:=X*Cos(Y);
 Vysledek.Im:=X*Sin(Y); {Nebo tak nejak}
end;

Procedure Odmocni;
var X : Real;
    P : Komplex;
Begin
  P.Re:=1;
  P.Im:=0;

  Del(P,B,B); {Ale ne vzdy to bude fungovat}
  Mocni(A,B,Vysledek);
End;

End.

************************************************************************************************

program Adresar;
{Program vytvori oboustranne zretezeny seznam kontaku, je znacne nedodelany,
divne je reseno napr. pridavani kontaktu (smite zadat jen tolik novych,
kolik jich prave v seznamu je,...), chybi vyhledavani, import/export kontaktu,
v abeceda rozhoduji velka/mala pismena... Nejsou osetreny pripady blbeho
uzivatele - zadani neexistujiciho jmena souboru, ulozeni prazdneho adresare
...}
{Ukonceni zadavani jmen - zadejte prazdne jmeno}

{Ukazeme si praci se souborem udaneho typu,
uvidime, ze vznikla data jsou znacne neprehledna... 
(podivejte se na ne v Notepadu a srovnejte s verzi uvedenou v prikladech pro pokrocile I)}

type PSeznam = ^TSeznam;
     TData   = record
                    Jmeno : string[50];
		   Telefon: string[12];
		    Email : string[50];
		   end;
     TSeznam = record
                Data  : TData;
            Predchozi : PSeznam;
                Dalsi : PSeznam;
               end;
const UData : TData = (Jmeno:'nikdo';Telefon:'nema';Email:'zadny'); {Data hlavicky}
var Hlavicka,Soucasny : PSeznam;
    Seznam : TSeznam;
    ZData   : TData;
    r       : char;

procedure Inicializace; {Drzadlo}
begin
 New(Hlavicka);
 Hlavicka^.Dalsi:=Hlavicka;
 Hlavicka^.Predchozi:=Hlavicka;
 Hlavicka^.Data:=UData;
 Soucasny:=Hlavicka;
end;

procedure Zadej; {Vytvori kruhovy oboustranne zretezeny seznam}
begin
 repeat
 Write('Jmeno : ');
 Readln(ZData.Jmeno);
 if ZData.Jmeno <> '' then
  begin
   Write('Telefon : ');
   Readln(ZData.Telefon);
   Write('Email : ');
   Readln(ZData.Email);

   New(Soucasny^.Dalsi);
   Soucasny^.Dalsi^.Predchozi:=Soucasny;
   Soucasny:=Soucasny^.Dalsi;
   Soucasny^.Data:=ZData;
   Soucasny^.Dalsi:=Hlavicka;
   Writeln;
  end;
 until ZData.Jmeno='';
end;

procedure Vypis; {Vypise cely seznam}
var Zobrazeno : Byte; {Aby se vse veslo na obrazovku}
begin
 Zobrazeno:=0;
 Writeln('Cely seznam :');
 Soucasny:=Hlavicka;
 Writeln;

 repeat
 Inc(Zobrazeno);
 Soucasny:=Soucasny^.Dalsi;
 Writeln(Soucasny^.Data.Jmeno);
 Writeln('Telefon :',Soucasny^.Data.Telefon:12,'    Email : ',Soucasny^.Data.Email);
 Writeln; {Pro prehlednost}
 if Zobrazeno = 7 then
  begin
   Writeln;
   Writeln('Press ENTER to continue');
   Readln;
  end;
 until Soucasny^.Dalsi=Hlavicka;
 Writeln('To je vse - Press ENTER to continue');
 Readln;
end;

procedure Zmen; {Vypise vsechny prvky a zepta se na moznost zmeny}
var c:char;
begin
 Writeln('Cely seznam :');
 Soucasny:=Hlavicka;
 repeat
 Soucasny:=Soucasny^.Dalsi;
 Writeln(Soucasny^.Data.Jmeno,Soucasny^.Data.Telefon:15,Soucasny^.Data.Email:30, ' Zmenit(A/N):');
 Readln(c);
 c:=UpCase(c);
 if C='A' then
  begin
   Write('Nove jmeno :');
   Readln(ZData.Jmeno);
   Write('Novy telefon :');
   Readln(ZData.Telefon);
   Write('Novy email :');
   Readln(ZData.Email);
   Soucasny^.Data:=ZData;
  end;
 until Soucasny^.Dalsi=Hlavicka;
 Writeln('To je vse');
end;

procedure Odstran; {Odstrani vybrane prvky ze seznamu}
var Smaz:PSeznam;
    c   :char;
begin
 Writeln('Cely seznam :');
 Soucasny:=Hlavicka;
 repeat
 Soucasny:=Soucasny^.Dalsi;
 Writeln(Soucasny^.Data.Jmeno,Soucasny^.Data.Telefon:15,Soucasny^.Data.Email:30,' Odstranit(A/N)');
 Readln(c);
 c:=UpCase(c);
 if C='A' then
  begin
   Smaz:=Soucasny;
   Soucasny^.Predchozi^.Dalsi:=Soucasny^.Dalsi;
   Smaz^.Dalsi^.Predchozi:=Smaz^.Predchozi;
   Soucasny:=Smaz^.Predchozi;
   Dispose(Smaz); {Mazeme az ted!!}
  end;
  until Soucasny^.Dalsi=Hlavicka;
 Writeln('To je vse');
end;

procedure Pridej; {Prida novy prvke}
var Novy:PSeznam;
    c   :char;
begin
 Writeln('Cely seznam :');
 Soucasny:=Hlavicka;
 repeat
 Soucasny:=Soucasny^.Dalsi;
 Writeln(Soucasny^.Data.Jmeno:20,Soucasny^.Data.Telefon:15,Soucasny^.Data.Email,' Pridat pred(A/N)');
 Readln(c);
 c:=UpCase(c);
 if C='A' then
  begin
   Write('Nove jmeno : ');
   Readln(ZData.Jmeno);
   Write('telefon : ');
   Readln(ZData.telefon);
   Write('email : ');
   Readln(ZData.Email);
   New(Novy);
   Novy^.Data:=ZData;

   Novy^.Dalsi:=Soucasny;
   Novy^.Predchozi:=Soucasny^.Predchozi;
   Soucasny^.Predchozi:=Novy;
   Novy^.Predchozi^.Dalsi:=Novy; {To jsou snad cary, ale je to tak, ukazatele ted sedi}

  end;
  until Soucasny^.Dalsi=Hlavicka;
 Writeln('To je vse');
end;

procedure Serad; {Seradi data podle abecedy}
var Zmen : LongInt; {Pocet dvojic prehozenych pri jednom pruchodu}
    Konec: Boolean;
begin
 Zmen:=0;
 Soucasny:=Hlavicka;
 repeat
 if Konec then
  begin
   Zmen:=0;
   Konec:=false;
  end;
 Konec:=Soucasny^.Dalsi=Hlavicka;
 if (Soucasny=Hlavicka) or (Soucasny^.Dalsi=Hlavicka) then {if then else lze takto pouzit}
  else
   if Soucasny^.Data.Jmeno > Soucasny^.Dalsi^.Data.Jmeno then
   Begin
    Inc(Zmen);
    Zdata:=Soucasny^.Data;
    Soucasny^.Data:=Soucasny^.Dalsi^.Data;
    Soucasny^.Dalsi^.Data:=ZData;
   End;
 Soucasny:=Soucasny^.Dalsi;
 until Konec and (Zmen=0);
end;

procedure Nahraj; {Nacte oboustranne zretezeny seznam}
var JmenoSouboru : string;
    fData        : file of TData;
begin
 Write('Nacist ze souboru (udavejte bez pripony) : ');
 Readln(JmenoSouboru);
 JmenoSouboru:=JmenoSouboru+'.adr';
 Assign(fData,JmenoSouboru);
 Reset(fData);
 repeat
  New(Soucasny^.Dalsi);
  Read(fData,Soucasny^.Dalsi^.Data);
  Soucasny^.Dalsi^.Predchozi:=Soucasny;
  Soucasny:=Soucasny^.Dalsi;
  Soucasny^.Dalsi:=Hlavicka;
 until Eof(fData);
 Close(fData);
end;

procedure Uloz; {Ulozi oboustranne zretezeny seznam}
var JmenoSouboru : string;
    fData        : file of TData;
begin
 Write('Ulozit do souboru (jmeno udavejte bez pripony) : ');
 Readln(JmenoSouboru);
 JmenoSouboru:=JmenoSouboru+'.adr';
 Assign(fData,JmenoSouboru);
 Rewrite(fData);
 Soucasny:=Hlavicka;
 repeat
 Soucasny:=Soucasny^.Dalsi;
 Write(fData,Soucasny^.Data);
 until Soucasny^.Dalsi=Hlavicka;
 Close(fData); {Jinak by se ani neulozil na disk}

end;


begin
 Inicializace;
 repeat
 writeln('Co chcete delat : ');
 writeln;
 writeln('V - Vytvorit novy adresar');
 writeln('Z - Zobrazit seznam');
 writeln('O - Opravit udaje');
 writeln('S - Smazat nektera data');
 writeln('P - Pridat nove prvky');
 writeln('E - Seradit podle abecedy');
 writeln('N - Nahrat ze souboru');
 writeln('U - Ulozit do souboru');
 writeln('K - Koncit');
 Readln(R);
 R:=UpCase(R);
 case R of
  'V': Zadej;
  'Z': Vypis;
  'O': Zmen;
  'S': Odstran;
  'P': Pridej;
  'E': Serad;
  'N': Nahraj;
  'U': Uloz;
 end;
 until R='K';
end.
***********************************************************************************************

program KombinacniCislo;
{Vypocte n nad k pomoci jednoduche rekurze}
var N,K:Integer;

function NnadK(N,K:Integer):Longint; {S realnymi cisly radeji pracovat nebudeme}
{Vypocte NnadK pomoci znameho rekurentniho vztahu,
lepsi by bylo pouzit primy vypocet, (dobre napsany),
ale takhle si aspon zopakujeme rekurzi}
var X:Longint; {Pomocna promenna}
begin
 if N < K then RunError(215); {Neni definovano - spusti error}
 X:=0;
 if N=K then X:=1;
 if K=1 then X:=N;
 if K=0 then X:=1;
 if X>0 then
  begin
   NnadK:=X;
   Exit;
  end;
 NnadK:=NnadK(N-1,K)+NnadK(N-1,K-1); {Znamy to vzorec}
end;

begin
 Writeln('Zadejte dve cisla');
 Readln(N,K);
 Writeln('Binomial(',N, ',', K,') =', NNadK(N,K));
 Readln;
end.
******************************************************************************

program PocetNul;
{Zjisti kolika nulami konci n!}
var N,I,Nul : integer;
begin
 Write('Zadej cislo : ');
 Readln(N);

 I:=1;
 Nul:=0;
 repeat
 I:=I*5;
 Nul:=Nul + (N div I)
 until (N div I)=0;
 {Pred kazdou petkou je sude cislo a sude cislo krat pet je jedna nula navic,
 nesmime ovsem zapomenout, ze pokud jde o 25, tak dve nuly, 125 tri, atd...}

 Writeln('Pocet nul u n! : ', Nul);

 Readln;
end.
*****************************************************************************

program Rozklad;
{Program rozlozi zadane cislo na soucin prvocisel - ovsem znacne neefektivni
metodou, delitele ulozi do jednostranne zretezeneho seznamu, nemuzeme totiz dopredu vedet,
kolik jich bude}
type PDelitel = ^Delitel;
     Delitel = record
                Dalsi   : PDelitel;
                Cislo   : Longint;
                Mocnina : Longint;
               end;
var N,X,Y,Z,I:Longint;
    Zacatek,Aktualni:PDelitel;

begin
 New(Zacatek);
 Aktualni:=Zacatek;
 Aktualni^.Cislo:=1;
 Aktualni^.Mocnina:=0; {Inicializace seznamu}

 Write('Zadejte prirozene cislo : ');
 Readln(N); {Zadani dat}
 X:=2;
 Y:=N;

 repeat
  for I:=X to Y do
   if Y mod X = 0 then
    begin
     New(Aktualni^.Dalsi);      {Zarazeni prvku na konec seznamu}
     Aktualni:=Aktualni^.Dalsi;
     Aktualni^.Cislo:=X;
     Aktualni^.Dalsi:=nil;
     Z:=0;
     repeat
      Inc(Z);      {Zjisteni mocniny, ve ktere se delitel vyskytuje}
      Y:=Y div X;
     until (Y mod X) <> 0;
     Aktualni^.Mocnina:=Z;
    end;
  Inc(X);  {Nesmime zapomenout zvysit proverovany delitel, jinak se program zacykli}
 until Y=1;

 Writeln('Delitele :'); {Vypis}
 Aktualni:=Zacatek;
 repeat
  Aktualni:=Aktualni^.Dalsi;
  Writeln(Aktualni^.Cislo,' ^ ',Aktualni^.Mocnina);
 until Aktualni^.Dalsi=nil;
 Readln;
end.
*****************************************************************************

program DokonalaCisla;
{Program najde vsechna dokonala cisla, tedy cisla, soucet jejichz delitelu je
roven n (nepocitame-li cislo n samo). Omezuje se pritom na rozsah typu longint
a vyuziva zname poucky, ze pokud je cislo dokonale, tak lze vyjadrit jako
1 + 2 + 3 + 4 + ... + x-1 + x}
var N,S,D,I : Integer;
begin
 D:=1;
 N:=0;
 S:=0;
 repeat
 N:=N+D;
 D:=D+1;
 for I:=1 to (N div 2) do
  if N mod I = 0 then S:=S+I; {Pokud je N delitel, zvysime o nej prislusnou sumu delitelu}
 if N=S then Writeln(N); {Pokud je suma delitelu rovna danemu cislu, jde o cislo dokonale, tak ho napiseme}
 S:=0;

 until N < 0; {Znamka preteceni, jenom doufam, ze mate dostatek trpelivosti, asi tak deset let}
              {Napsat to takhle je fakt prasarna, takze pokud vas nekdy neco
              podobneho napadne, bezte k psychiatrovi}
 readln;      {Pricitame-li totiz postupne, nemuze se nam stat, ze bychom casem nepretekli...}
end.
********************************************************************************

program Kraceni;
{Zadejte citatel a jmenovatel a dostanete zlomek v zakladnim tvaru}
var Citatel,Jmenovatel,P:Longint;

Function Delitel(a,b:LongInt):LongInt; {Kratime totiz nejvetsim spolecnym delitelem}
Begin
 if a > b then a:=a-b else b:=b-a; {Delitel obou cisel bude i delitelem jejich rozdilu}
 if (b=0) or (a=0) then Delitel:=a + b else Delitel:=Delitel(a,b);
End;

begin
 Write('Zadejte citatele a jmenovatele : ');
 Readln(Citatel,Jmenovatel);
 P:=Delitel(Abs(Citatel),Abs(Jmenovatel));
 Write(Citatel, '/',Jmenovatel, ' = ');
 Citatel:=Citatel div P;
 Jmenovatel:=Jmenovatel div P;
 if Jmenovatel < 0 then {U zakladniho tvaru se pozaduje kladny jmenovatel}
  begin
   Citatel:=-Citatel;
   Jmenovatel:=-Jmenovatel; {Hodnotu zlomku nezmenime, zmenime-li znamenka citatele i jmenovatele}
  end;
 if Jmenovatel = 1 then Writeln(Citatel) else Writeln(Citatel,'/',Jmenovatel);
 Readln;
end.
******************************************************************************

program Piskvorky;
{Umozni dvema hracum hrat piskvorky (na pet viteznych) v poli 20x20.
Lehce vyuziva pascalovske grafiky, je mozne tez napsat jen s pouzitim Crt, ale
v horsi obrazove kvalite. Machri pouziji primy pristup do videopameti ci Directy
nezapomente umistit spravny graficky ovladac (nejspise EGAVGA.BGI) do adresare s programem
(pokud ho chcete dale sirit, ci alespon uvest cestu v InitGraph. Mnohem lepsi
metoda je ale pouzit assembler, ci nalinkovat graficky ovladac primo do programu,
nemusite se pak obtezovat s nepotrebnymi soubory - ale zatim vas s tim nebudu
zatezovat, jak se to dela se dozvite az v prikladech venovanych grafice}

{Ac je program napsan docela srozumitelne, doporucuji si ho projit a
vsechny jeho funkce zduvodnit, sami uvidite, jak se to, ze jsem nenapsal
moc komentaru, odrazi na vasi schopnosti se v tom vyznat}

Uses Graph,Crt;
Const XRozmer        =10; {Mozno zmenit}
      YRozmer        =10;
      XRohu          =33; {X souradnice Praveho horniho rohu}
      YRohu          =33; {Y souradnice Praveho horniho rohu}
      XPocetPoli     =20;
      YPocetPoli     =20;
      Maximum        =20; {To vetsi z cisel XPocetPoli, YPocetPoli}
      BarvaOhraniceni=7;
      BarvaKrizku    =15;
      BarvaKolecek   =15;
      BarvaVitezstvi =14;
      Prodleva       =2; {Kolik sekund se vitez kocha svym triumfem}

Type Policko = -1..1;
     Smer    = record
                X:Policko;
                Y:Policko;
               end;
Const  Smery : array[1..4] of Smer = ((X:-1;Y:-1),(X:-1;Y:0),(X:-1;Y:1),
                                     (X:0;Y:-1));
                                     {Mozne smery vytvoreni vyherni kombinace}
Var Gd,Gm:Integer;
    Pole: array[-4..XPocetPoli+4,-4..YPocetPoli+4] of Policko;
    {Pole je sirsi, abychom nemuseli pocitat s hranicemi pri kontrole vitezstvi}
    I,J:-4..Maximum+4;
    X,Y:Word;
    Hrac:-1..1;
    Konci:Boolean;
    Vitez:Policko;
    c    :char;
Procedure NastavPole; {Nastaveni herni pole}
Begin
Vitez:=0;
for I:=-4 to XPocetPoli+4 do
  for J:=-4 to YPocetPoli+4 do
    Pole[I,J]:=0;
end;


Procedure KresliMriz; {Nakresli hraci pole}
Begin
  SetColor(BarvaOhraniceni);
 X:=XRohu+XPocetPoli*XRozmer;
 Y:=YRohu+YPocetPoli*YRozmer;
 for I:=0 to XPocetPoli do               {Vykresli hraci pole}
   Line(XRohu+I*XRozmer,YRohu,XRohu+I*XRozmer,Y);
 for I:=0 to YPocetPoli do
   Line(XRohu,YRohu+I*YRozmer,X,YRohu+I*YRozmer);
  {Neni nad poradny zmatek, ale kdyz je to zapsane takto, nikdy nebude treba menit neco
  primo ve zdrojovem kodu}
End;


Procedure NastavKurzor;
Begin
 X:=XPocetPoli div 2;
 Y:=YPocetPoli div 2; {Umisti kurzor doprostred hraci plochy}
End;

Procedure KresliKurzor(Barva:Policko);
Begin
 case Barva of
 -1:SetColor(BarvaKrizku);
 0:SetColor(Black);
 1:SetColor(BarvaKolecek);
 end;
 Line(XRohu+(X-1)*XRozmer+1,YRohu+(Y-1)*YRozmer+(YRozmer div 2),XRohu+X*XRozmer-1,YRohu+(Y-1)*YRozmer+(YRozmer div 2));
End;

procedure KresliKolecko(X,Y:Byte);
begin
 SetColor(BarvaKolecek);
 if Vitez=1 then SetColor(BarvaVitezstvi);
 Circle(XRohu+X*XRozmer-XRozmer div 2,YRohu+Y*YRozmer-YRozmer div 2,(XRozmer div 2 -1))
end;

procedure KresliKrizek(X,Y:Byte);
begin
 SetColor(BarvaKrizku);
 if Vitez=-1 then SetColor(BarvaVitezstvi);
 Line(XRohu+(X-1)*XRozmer,YRohu+(Y-1)*YRozmer,XRohu+X*XRozmer,YRohu+Y*YRozmer);
 Line(XRohu+(X-1)*XRozmer,YRohu+Y*YRozmer,XRohu+X*XRozmer,YRohu+(Y-1)*YRozmer);
end;

procedure KresliZnak(X,Y:Byte);
begin
 if Pole[X,Y]=-1 then KresliKrizek(X,Y);
 if Pole[X,Y]=1 then KresliKolecko(X,Y);
end;

procedure Vyhra(Plus,Minus,J:Byte);
var I:Integer;
begin
 KresliKurzor(0);
 Vitez:=Hrac;
 Konci:=True;
 KresliZnak(X,Y);
 for I:=1 to Plus do
  KresliZnak(X+I*Smery[J].X,Y+I*Smery[J].Y);
 for I:=1 to Minus do
  KresliZnak(X-I*Smery[J].X,Y-I*Smery[J].Y);
 end;

procedure ZkontrolujVyhru;
var Plus,Minus: Byte;
    PPlus,PMinus : Boolean;
Begin
 for I:=1 to 4 do
  begin
   PPlus:=True;
   PMinus:=True;
   Plus:=0;
   Minus:=0;
   for J:=1 to 4 do
    begin
     if (Pole[X+J*Smery[I].X,Y+J*Smery[I].Y]=Hrac) and PPlus then Inc(Plus)
      else PPlus:=false;
     if (Pole[X-J*Smery[I].X,Y-J*Smery[I].Y]=Hrac) and PMinus then Inc(Minus)
      else PMinus:=false;
    if Plus+Minus>=4 then Vyhra(Plus,Minus,I);
    end;
  end;
End;


procedure CtiKlavesu(C:char);
begin
  if C='X' then Konci:=true;
  if (C=' ') and (Pole[X,Y] = 0) then
   begin
    Pole[X,Y]:=Hrac;
    if Hrac=-1 then
      begin
       KresliZnak(X,Y);
       ZkontrolujVyhru;
       Hrac:=1;
      end
     else
      begin
       KresliZnak(X,Y);
       ZkontrolujVyhru;
       Hrac:=-1;
      end;
   end;
  if (C='K') and (X>1) then
   begin
    KresliKurzor(0); {Nejdrive smazeme ten stary}
    KresliZnak(X,Y); {Obnovi preruseny znak}
    Dec(X); {Sipka doleva}
    KresliKurzor(Hrac);
   end;
  if (C='M') and (X<XPocetPoli) then {Sipka doprava}
   begin
    KresliKurzor(0);
    KresliZnak(X,Y);
    Inc(X); {Sipka doleva}
    KresliKurzor(Hrac);
   end;
  if (C='H') and (Y>1) then {Sipka nahoru}
   begin
    KresliKurzor(0);
    KresliZnak(X,Y);
    Dec(Y); {Sipka doleva}
    KresliKurzor(Hrac);
   end;
  if (C='P') and (Y<YPocetPoli) then {Sipka dolu}
   begin
    KresliKurzor(0);
    KresliZnak(X,Y);
    Inc(Y); {Sipka doleva}
    KresliKurzor(Hrac);
   end;


  if (C='G') and (X>1) and (Y>1) then {Sikme smery pomoci Page Up...}
   begin
    KresliKurzor(0);
    KresliZnak(X,Y);
    Dec(X);
    Dec(Y);
    KresliKurzor(Hrac);
   end;
  if (C='I') and (X<XPocetPoli) and (Y>1) then
  begin
    KresliKurzor(0);
    KresliZnak(X,Y);
    Inc(X);
    Dec(Y);
    KresliKurzor(Hrac);
   end;
  if (C='O') and (X>1) and (Y<YPocetPoli) then
  begin
    KresliKurzor(0);
    KresliZnak(X,Y);
    Dec(X);
    Inc(Y);
    KresliKurzor(Hrac);
   end;
  if (C='Q') and (X<XPocetPoli) and (Y<YPocetPoli) then
  begin
    KresliKurzor(0);
    KresliZnak(X,Y);
    Inc(X);
    Inc(Y);
    KresliKurzor(Hrac);
   end;
end;

Procedure Hraj;
var c : char;
Begin
 ClearDevice;
 Hrac:=-1;
 KresliMriz;
 NastavPole;
 NastavKurzor;
 KresliKurzor(-1);
 repeat
  C:=ReadKey;
  C:=UpCase(C);
  CtiKlavesu(C);
 until Konci;
 if Vitez<>0 then Delay(1000*Prodleva);
End;

Begin
 Gd:=Detect;
 InitGraph(Gd,Gm,'F:\work\BP\BGI');
 {Napiste cestu ke pascalovskemu grafickemu ovladaci (tj. souboru EGAVGA.BGI)}
 repeat
  Hraj;
  ClearDevice;
  OutText('Prejete si pokracovat (A/N) ?');
  repeat until KeyPressed;
  C:=UpCase(ReadKey);
  if C='A' then Konci:=False;
 until Konci=true;
 CloseGraph; {Nezapomeneme uklidit}
End. {Slo by to udelat i jednodusseji}
******************************************************************************

program Formatovac;
{Trosku zvyrazni barvicky pascalovskeho kodu,
je zretelne inspirovan jazykem C, ale bez komentaru
vyznate se v tomhle programu?}

{Mozna by bylo hezke udelat odsazeni beginu a podobne ptakoviny,
ale pak bychom se v tomhle programu nevyznali,
dale chybi takova ta srandicka - zvyrazneni vseho, co je mezi
ASM a nejblizsim endem zelene}

{Muzete si jeste pohrat s TextBackground}

uses Crt,Strings; {Budeme potrebovat trochu barvy a s retezci pracujeme urcite}
const Normal = Yellow;
      Reserved = White;
      Commentary=DarkGray;

var FInName : string;
    fin     : text;
    slovo   : string;
    c       : char;


function UpperCase(s:string):string; {s neni volana odkazem, muzeme ji
tedy uvnitr funkce beztrestne menit}
var i:integer;
begin
 for i:=1 to length(s) do
     s[i]:=UpCase(s[i]);
 UpperCase:=s;
end;

function IsAlpha(c:char):Boolean; {Zjisti, zda je zadany znak pismeno}
begin
 case c of
  'a'..'z':IsAlpha:=True;
  'A'..'Z':IsAlpha:=True;
  else IsAlpha:=False;
  end;
end;

function IsReserved(s:string):Boolean; {Zjisti, zda je dane slovo vyhrazene}
const
PocetSlov=64;
Reserved:array[1..PocetSlov] of string[15] =
('AND','ARRAY','ASM','BEGIN','CASE','CONST','CONSTRUCTOR','DESTRUCTOR',
 'DIV','DO','DOWNTO','ELSE','END','EXPORTS','FILE','FOR',
 'FUNCTION','GOTO','IF','IMPLEMENTATION','IN','INHERITED','INLINE','INTERFACE',
 'LABEL','LIBRARY','MOD','NIL','NOT','OBJECT','OF','OR',
 'PACKED','PROCEDURE','PROGRAM','RECORD','REPEAT','SET','SHL','SHR',
 'STRING','THEN','TO','TYPE','UNIT','UNTIL','USES','VAR',
 'WHILE','WITH','XOR','ABSOLUTE','ASSEMBLER','EXPORT','EXTERNAL','FAR',
 'FORWARD','INDEX','INTERRUPT','NEAR','PRIVATE','PUBLIC','RESIDENT','VIRTUAL');
{pole vsech vyhrazenych slov a direktiv}
var i:integer;
   pom:boolean;
begin
 s:=UpperCase(s); {Prevedeme na velka pismena}

 pom:=false;
 for i:=1 to PocetSlov do
  if s=reserved[i] then
   begin
    pom:=true;
    break;
   end;
 IsReserved:=pom;
end;

procedure PisReserved(s:string);
begin
 TextColor(Reserved);
 Write(s);
 TextColor(Normal);
end;

procedure Pis(s:string);
begin
 TextColor(Normal);
 Write(s);
end;

begin
 Writeln('Zadej jmeno pascalovskeho souboru, vcetne pripony: ');
 Readln(fInName);
 Assign(fin,fInName);
 Reset(fin); {Bez kontroly je to takove neprofesionalni}
 repeat
  Slovo:='';
  repeat
   Read(fin,c);
   if IsAlpha(c) then slovo:=slovo+c;
   if not IsAlpha(c) then
    if IsReserved(slovo) then PisReserved(slovo)
    else Pis(slovo); {patri k druheme if}
   until not IsAlpha(c);

 if c='{' then
  begin
   TextColor(Commentary);
   write('{');
   repeat
    read(fin,c);
    write(c);
   until c='}';
   TextColor(Normal);
   read(fin,c);
  end;
 write(c);
 until Eof(fIn);

 readln;

 TextColor(7); {Vratime puvodni nastaveni}
 ClrScr;
end.

program hanojske_veze;
{Tento program resi jednoduchou rekurzi klasicky problem hanojskych vezi.
Pokud zadate n>20, mozna si nekolik dni pockate, nez program skonci.

Co potrebuji k tomu, abych celou n-prvkovou vez prendal jinam?
Presunout n-1 prvkovou vez nad spodnim kolikem na odkladaci sloupecek,
pak presunout ten spodni kolik na cilove misto
a celou vez z odkladaciho koliku dat na nej.
A jelikoz (n-1)-prvkove veze presunu stejnou procedurou,
staci ji zavolat znovu na o neco mensi vez.
No a kdyz uz mam presouvat jen jeden kolik, tak ho jen presunu,
rekurze je zbytecna.

Tento program je ukazkou toho, jak se rekurzi resi problemy.
Predpokladam, ze umim vyresit vsechny problemy mensi,
tak svuj problem prevedu na ne.
Problemy jsou mensi a mensi a mensi... az je umime vyresit.
Jinou ukazkou takoveho pristupu je napr. QuickSort.
}
uses Crt;

const MaxVezi=100;
type tsloupec=1..3;
     TData=array[1..MaxVezi] of tsloupec; {Jelikoz program prendava veze korektne
                                           staci si pro konkretni kolik(ktery je urcen svou velikosti) pamatovat,
                                          ve kterem sloupecku je.}
var celkem:integer;
    Data:TData;

procedure Vypis(var Data:TData;pocet:integer);
{Vypise soucasnou pozici hanojske veze, lepsi by byl zapis do souboru}
var sloupce:array[1..3] of 1..MaxVezi;
    i,j:integer;
    pr :word;
begin
 pr:=round(ln(pocet)/ln(10))+2; {Presnost vypisu, aby se pri vysokych
                                cislech neslevali do jednoho a pri malych
                                nebyly kilometry od sebe.}
 for i:=1 to 3 do
  begin
   write('#');
   for j:=pocet downto 1 do
    if Data[j]=i then write(j:pr);
   writeln;
  end;
end;

function volno(sloupec1,sloupec2:tsloupec):tsloupec;{
{Zjistime, ktery sloupec je volny jako odkladaci}
var i:tsloupec;
begin
 for i:=low(tsloupec) to high(tsloupec) do
  if (i<>sloupec1) and (i<>sloupec2) then volno:=i;
end;

procedure presun(var data:Tdata;pocet:integer;odkud,kam:tsloupec);
{vlastni rekurzivni procedura}
var odloz:tsloupec;
begin
 odloz:=volno(odkud,kam);
 if pocet>1 then presun(data,pocet-1,odkud,odloz);{jinak neni co presouvat}
 data[pocet]:=kam;                               {a presuneme spodni}
 Vypis(data,celkem);writeln;
 if pocet>1 then presun(data,pocet-1,odloz,kam); {no a odlozenou vez presuneme zpatky}
end;

procedure hanoj(var data:Tdata;pocet:integer);
{nastavi vez a vyresi ji}
var I:integer;
begin
 for i:=1 to pocet do
  data[i]:=1;
 Vypis(Data,celkem);
 writeln;
 presun(data,pocet,1,3);
end;

begin
 readln(celkem);
 ClrScr;
 if (celkem>MaxVezi) or (celkem<1) then writeln('Toto neni spravna vyska veze')
 else hanoj(data,celkem);
 readln;
end.