program Razeni1;
{Stupidni programek na serazeni dvou hodnot podle velikosti,
s vyhodou vyuziva proceduru prohod}
type MujTyp=integer;

procedure Prohod(var x,y:mujtyp);
var pom:mujtyp;
begin
 pom:=x;
 x:=y;
 y:=pom;
end;

var x,y:mujtyp;

begin
 readln(x,y);
 if x<y then prohod(x,y);
 writeln('Promenne razene sestupne: ');
 writeln('x = ',x);
 writeln('y = ',y);
 readln;
end.
****************************************************************************
program Razeni2;
{Seradi pole prvku dle velikosti, ilustruje algoritmy GnomeSort,
BubbleSort, SelectSort, QuickSort a porovnava jejich rychlost}
uses Crt;

const delka=999; {Pocet prvku pole}
type MujTyp=integer; {Tedka muzu typ kdykoli zmenit s minimalnim usilim
                     jenom funkce srovnej a prohod se v takovem
                     pripade budou muset trosku upravit}
     Tvysledek  =-1..1;{mensi, rovno, vetsi}
     Tsrovnavaci=function(x,y:Mujtyp):Tvysledek; {srovnavaci funkce, dle ktere
                                                  se budou prvky radit}

procedure Prohod(var x,y:mujtyp);
{Uzitecna procedurka na prohozeni dvou prvku}
var pom:mujtyp;
begin
 pom:=x;
 x:=y;
 y:=pom;
end;

function srovnej(x,y:Mujtyp):Tvysledek;far;
{funkce, ktera srovnava dva prvky, prirazuji ji do promenne,
musi byt tedy volana vzdalene.. proto to far
pokud by byl napr. mym typem record, mohl byt zde uvest
srovnavani dle libovolne polozky a libovolny sort by i nadale fungoval}
begin
 if x<y then srovnej:=1
  else
   if x=y then srovnej:=0
    else srovnej:=-1;
end;

type Tpole=array[1..delka] of MujTyp;


procedure Generuj(var Pole:Tpole);
{vytvori nahodne pole}
var i:1..delka;
begin
 for i:=1 to delka do
  Pole[i]:=random(maxint);
end;

procedure Vypis(var Pole:Tpole);
{vypise pole, vzdy se hodi mit takovouto procedurku po ruce kvuli ladeni}
var i:1..delka;
begin
 for i:=1 to delka do
  write(pole[i]:8);
 writeln;
end;

function Kontroluj(var Pole:Tpole;porovnej:Tsrovnavaci):Boolean;
{Zkontroluje, zda je pole spravne serazene}
var i:1..delka;
    pom:boolean;
begin
 pom:=true; {Funkce a procedury a inicializovane promenne nejdou dohromady}
 for i:=1 to delka-1 do
  if porovnej(pole[i],pole[i+1])<0 then
   begin
    pom:=false;
    break;
   end;
 kontroluj:=pom;
end;

procedure GnomeSort(var Pole:Tpole;porovnej:Tsrovnavaci);
{Nejpomalejsi a nejhorsi tridici algoritmus vubec.
Prohledava pole od zacatku a kdyz nahodou najde dvojici,
ktera neni ve spravnem poradi, tak ji prohodi a zacne
pole prohledavat od zacatku.
Casova slozitost N^3, pametova konstantni.}
var i:1..delka;
begin
 i:=1;
 repeat
  if porovnej(pole[i],pole[i+1])<0 then
   begin
    prohod(pole[i],pole[i+1]);
    i:=1;
   end
   else
    i:=i+1;
 until i=delka;
end;

procedure BubbleSort(var Pole:Tpole;porovnej:Tsrovnavaci);
{Jednoduchy, ale pomaly tridici algoritmus.
Porovnava sousedni dvojicky, pokud nejsou prvky ve spravnem
poradi, tak je prohodi. V prvnim kroku tak nahoru probubla nejvetsi prvek,
v druhem se pod nej dostane druhy nejmensi atd...
Casova slozitost N^2, pametova konstantni}
var i,j:1..delka;
begin
 for i:=1 to delka do
  for j:=1 to delka-i do {Lze napsat i delka-1, ale povede to ke zpomaleni}
   if porovnej(pole[j],pole[j+1])<0 then Prohod(pole[j],pole[j+1]);
end;

procedure SelectSort(var Pole:Tpole;porovnej:Tsrovnavaci);
{Razeni metodou primeho vyberu.
Jednoduchy a pomaly tridici algoritmus. O neco lepsi nez BubbleSort.
Vybereme nejmensi prvek a dame
ho na prvni misto. Pak vybereme druhy nejmensi a dame ho na druhe...
Casova slozitost N^2, pametova konstantni}
var i,j,k:1..delka;
    min:mujtyp;
begin
 for i:=1 to delka do
  begin
   min:=pole[i];
   k:=i;
   for j:=i+1 to delka do
    if porovnej(min,pole[j])<0 then
     begin
      min:=pole[j];
      k:=j;
     end;
   prohod(pole[i],pole[k]);
  end;
end;

procedure QuickSortR(var Pole:Tpole;odkud,kam:integer;porovnej:Tsrovnavaci);
{QuickSort, v jistem smyslu jedna z nejefektivnejsich metod razeni,
funguje takto: nejprve vybere pivota (to je libovolny prvek z pole)
a pak pole rozdeli na dve casti - na prvky, co jsou mensi nez pivot
a na prvky, co jsou vetsi. A na obe casti spusti ten samy algoritmus znova.
Tim, ze se vsechny prvky porovnavaji s jednim se znacne minimalizuje
nacitani dat do pameti, coz vede ke zrychleni algoritmu.
Existuji algoritmy, ktere maji slozitost Nlog(N) i v nejhorsim pripade
(MergeSort,HeapSort) ale prumerne jsou pomalejsi nez QuickSort.

Casova narocnost: N^2 v nejhorsim pripade, prumerne Nlog(N),
pametova narocnost log N}
var piv:mujtyp;{pivot}
    i,j:1..delka;
begin
 if odkud>=kam then Exit;
 piv:=pole[odkud];{existuje spousta literatury o spravnem
                   vyberu pivota(a spravnym vyberem lze algoritmus
                   zrychlit a vyhnout se slozitosti n^2),
                   my ale jednodusse vybereme prvni prvek)}
 j:=odkud;
 i:=odkud;
 for i:=odkud to kam do
 if porovnej(piv,pole[i])<0 then
  begin
   j:=j+1;
   prohod(pole[i],pole[j]);
  end;
 prohod(pole[odkud],pole[j]);{Zamyslete se nad tim, proc tyhle
                             radky znamenaji, ze jsme pole rozdelili
                             na prvky pred a za pivotem}
 QuickSortR(pole,odkud,j-1,porovnej); {a nakonec rekurzivni spusteni}
 QuickSortR(pole,j+1,kam,porovnej);
end;

procedure QuickSort(var Pole:Tpole;porovnej:Tsrovnavaci);
{Tohle je takova berlicka, abychom nemuseli v hlavnim programu
psat nesmyslne QuickSort(pole,porovnej,1,high(pole)}
begin
 QuickSortR(Pole,1,delka,porovnej);
end;

var pole:Tpole;
    x:integer;
    pom:boolean;
begin
 Randomize;
 ClrScr;

 write('Probiha 1xGnomeSort:');
 generuj(pole);
 GnomeSort(pole,srovnej);
 if kontroluj(pole,srovnej) then writeln('OK')
    else writeln('Neseradil pole spravne');

 pom:=true;
 write('Probiha 10xBubbleSort:');
 for x:=1 to 10 do
  begin
    generuj(pole);
    BubbleSort(pole,srovnej);
    pom:=pom and kontroluj(pole,srovnej);
  end;
 if pom then writeln('OK')
    else writeln('Nejake pole neseradil spravne');

 pom:=true;
 write('Probiha 100xInsertSort:');
 for x:=1 to 100 do
  begin
    generuj(pole);
    SelectSort(pole,srovnej);
    pom:=pom and kontroluj(pole,srovnej);
  end;
 if pom then writeln('OK')
    else writeln('Nejake pole neseradil spravne');

 pom:=true;
 write('Probiha 1000xQuickSort:');
 for x:=1 to 1000 do
  begin
    generuj(pole);
    QuickSort(pole,srovnej);
    pom:=pom and kontroluj(pole,srovnej);
  end;
 if pom then writeln('OK')
    else writeln('Nejake pole neseradil spravne');

 Writeln('Konec testu');
 readln;
end.

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

program MergeSort;
{Kratky ukazkovy program na to, jak spojit dva setridene seznamy
do jednoho. Setridene seznamy jsou generovany nahodne.}
uses Crt;
const delka1=100;
      delka2=78;

type mujtyp=longint;
     PData=^tdata;
     TData=record
            i:mujtyp;
            next:pdata;
           end;

function create(t:mujtyp):pdata;
var p:pdata;
begin
 p:=new(pdata);
 p^.next:=nil;
 p^.i:=t;
 create:=p;
end;

function done(start:pdata):pdata;
var s:pdata;
begin
 while(start<>nil) do
  begin
   s:=start^.next;
   dispose(start);
   start:=s;
  end;
  done:=start;
end;

function add(start:pdata;i:mujtyp):pdata;
begin
 new(start^.next);
 start:=start^.next;
 start^.i:=i;
 start^.next:=nil;
 add:=start;
end;

procedure vypis(start:pdata);
begin
 while(start<>nil) do
  begin
   write(start^.i:8);
   start:=start^.next;
  end;
end;

function merge(s1,s2:pdata):pdata;
{destruktivni merge sort, vrati ukazatel na setrideny seznam
ale znici oba puvodni seznamy tim, ze z nich udela jeden.
Nejjednodusi by bylo napsat tento algoritmus rekurzivne, ale
zabiral by zbytecne mnoho pameti}
var p,q,r:pdata;
begin
 if (s1=nil) then begin merge:=s2; exit; end;
 if (s2=nil) then begin merge:=s1; exit; end;
 if (s1^.i<s2^.i) then
    begin
     merge:=s1;
     p:=s1;
     q:=s2;
    end
  else
    begin
     merge:=s2;
     p:=s2;
     q:=s1;
    end;
 while (p^.next<>nil) do
  begin
   while (p^.next<>nil) and (p^.next^.i<=q^.i) do p:=p^.next;
   r:=p^.next;
   p^.next:=q;
   q:=r;
  end;
 p^.next:=q;
end;

function mergen(s1,s2:pdata):pdata;
{nedestruktivni merge sort, oba puvodni seznamy necha na miste,
a vytvori treti, setrideny, pokud by seznamy mely hlavicku,
byla by prace jednodussi}
var p:pdata;
    q:pdata;
begin
 if (s1=nil) and (s2=nil) then begin mergen:=nil; exit; end;
 p:=new(pdata);
 mergen:=p;
  if (s1<>nil) and (s2<>nil) then
   if s1^.i<s2^.i then begin p^.i:=s1^.i; s1:=s1^.next; end
    else begin p^.i:=s2^.i; s2:=s2^.next; end;
  if (s1<>nil) and (s2=nil) then begin p^.i:=s1^.i; s1:=s1^.next; end;
  if (s2<>nil) and (s1=nil) then begin p^.i:=s2^.i; s2:=s2^.next; end;

 while (s1<>nil) or (s2<>nil) do
  begin
   if (s1<>nil) and (s2<>nil) then
    if s1^.i<s2^.i then begin p:=add(p,s1^.i); s1:=s1^.next; end
     else begin p:=add(p,s2^.i); s2:=s2^.next; end;
   if (s1<>nil) and (s2=nil) then begin p:=add(p,s1^.i); s1:=s1^.next; end;
   if (s2<>nil) and (s1=nil) then begin p:=add(p,s2^.i); s2:=s2^.next; end;
  end;
end;


var p1,p2,s1,s2,s3:pdata;
    i:integer;
    t:longint;
begin
 Randomize;
 ClrScr;
 t:=random(20);
 p1:=create(t);
 s1:=p1;

 for i:=1 to delka1 do
  begin
   t:=t+random(10);
   p1:=add(p1,t);
  end;
 t:=random(10);

 p2:=create(t);
 s2:=p2;
 for i:=1 to delka2 do
  begin
   t:=t+random(20);
   p2:=add(p2,t);
  end;
 vypis(s1);
 writeln;writeln;
 vypis(s2);
 writeln;writeln;
 s3:=mergen(s1,s2);
 vypis(s3);writeln;writeln;
 if done(s1)<>nil then write('Nepodarilo se uvolnit pamet');
 if done(s2)<>nil then write('Nepodarilo se uvolnit pamet');
 if done(s3)<>nil then write('Nepodarilo se uvolnit pamet');
 readln;
 ClrScr;

 t:=random(20);
 p1:=create(t);
 s1:=p1;

 for i:=1 to delka1 do
  begin
   t:=t+random(10);
   p1:=add(p1,t);
  end;
 t:=random(10);

 p2:=create(t);
 s2:=p2;
 for i:=1 to delka2 do
  begin
   t:=t+random(20);
   p2:=add(p2,t);
  end;
 vypis(s1);
 writeln;writeln;
 vypis(s2);
 writeln;writeln;
 s3:=merge(s1,s2);
 vypis(s3);

 if done(s3)<>nil then write('Nepodarilo se uvolnit pamet');
 readln;
end.


************************************************************************************************************************
program Adresar;
{Ukonceni zadavani jmen - zadejte prazdne jmeno}

type PSeznam = ^TSeznam;
     TData   = record
                 Prijmeni : string[50];
                    Jmeno : string[12];
		    Plat  : longint;
		   end;
     TSeznam = record
                Data  : TData;
            Predchozi : PSeznam;
                Dalsi : PSeznam;
               end;
     tsrovnej=function(a,b:Tdata):boolean;
const UData : TData = (Prijmeni:'nikdo';Jmeno:'nema';Plat:0); {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('Prijmeni : ');
 Readln(ZData.Prijmeni);
 if ZData.prijmeni <> '' then
  begin
   Write('Jmeno : ');
   Readln(ZData.Jmeno);
   Write('Plat : ');
   Readln(ZData.Plat);

   New(Soucasny^.Dalsi);
   Soucasny^.Dalsi^.Predchozi:=Soucasny;
   Soucasny:=Soucasny^.Dalsi;
   Soucasny^.Data:=ZData;
   Soucasny^.Dalsi:=Hlavicka;
   Writeln;
  end;
 until ZData.Prijmeni='';
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.Prijmeni);
 Writeln('Jmeno :',Soucasny^.Data.Jmeno:12,'    Plat : ',Soucasny^.Data.Plat);
 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.Prijmeni,Soucasny^.Data.Jmeno:15,Soucasny^.Data.Plat:30, ' Zmenit(A/N):');
 Readln(c);
 c:=UpCase(c);
 if C='A' then
  begin
   Write('Nove prijmeni :');
   Readln(ZData.Prijmeni);
   Write('Novy jmeno :');
   Readln(ZData.jmeno);
   Write('Novy plat :');
   Readln(ZData.Plat);
   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.Prijmeni,Soucasny^.Data.Jmeno:15,Soucasny^.Data.Plat: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.Prijmeni:20,Soucasny^.Data.Jmeno:15,Soucasny^.Data.Plat,' Pridat pred(A/N)');
 Readln(c);
 c:=UpCase(c);
 if C='A' then
  begin
   Write('Nove prijmeni : ');
   Readln(ZData.Prijmeni);
   Write('jmeno : ');
   Readln(ZData.jmeno);
   Write('plat : ');
   Readln(ZData.Plat);
   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(f:tsrovnej); {Seradi data podle funkce serad}
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 f(soucasny^.data,soucasny^.dalsi^.data) then {vyuzijeme srovnavaci funkce}
   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; {Soubor s udanym typem, data se ukladaji v binarni podobe
    ]                             bohuzel pak nemusi jit prenest na jiny pocitac
                                  a nejsou citelne... proto je lepsi pouzivat textove soubory
                                  ty muzeme menit a editovat sami}
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;

function DlePlatu(a,b:tdata):boolean;far;
begin
 if a.plat<b.plat then DlePlatu:=false else DlePlatu:=true;
end;

function DleAbecedy(a,b:tdata):boolean;far;
begin
 if a.prijmeni<b.prijmeni then DleAbecedy:=false;
 if a.prijmeni>b.prijmeni then DleAbecedy:=true;
 if a.prijmeni=b.prijmeni
  then if a.jmeno<b.jmeno then DleAbecedy:=false else DleAbecedy:=true;
end;

begin
 Inicializace;
 repeat
 writeln('Co chcete delat : ');
 writeln;
 writeln('V - Vytvorit novy seznam');
 writeln('Z - Zobrazit seznam');
 writeln('O - Opravit udaje');
 writeln('S - Smazat nektera data');
 writeln('P - Pridat nove prvky');
 writeln('E - Seradit podle platu');
 writeln('F - 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(DlePlatu);
  'F': Serad(DleAbecedy);
  'N': Nahraj;
  'U': Uloz;
 end;
 until R='K';
end.