Třídící algoritmy InsertionSort, BubbleSort, ShakerSort, SelectionSort, HeapSort, MergeSort, QuickSort

{ SORTER.PAS                               Copyright (c) Petr Koupy }
{                                                                   }
{ Demonstrace trideni dat.                                          }
{                                                                   }
{ Ukázka práce většiny třídících algoritmů, které pro třídění       }
{ používají porovnávání dvou prvků. Program vytvoří náhodnou        }
{ posloupnost čísel, kterou zvoleným algoritmem setřídí.            }
{ Jednoduchým benchmarkem je rovněž možné porovnat časovou složitost}
{ jednotlivých algoritmů. Pro vykreselení grafů je použit jednoduchý}
{ grafický výstup. Program vznikl v rámci přípravy na maturitu.     }
{                                                                   }
{ Datum:01.05.2007                             http://www.trsek.com }
 
program sorter;
uses graph,crt,dos;
const xmax=639;
      ymax=479;
type Tpole=array[1..xmax] of integer;
     Tmalepole=array[1..7] of byte;
var graphdriver,graphmode:smallint;
    volba,pocet,k:byte;
    fronta:Tmalepole;
    ukol,hradlo:boolean;
 
procedure GenerujPole(var pole:Tpole);
var i:integer;
begin
  randomize;
  for i:=1 to xmax do pole[i]:=random(ymax-1)+1;
end;
 
procedure Vyjmout(pozice:integer;vstup:Tpole);
begin
  setcolor(black);
  line(pozice+1,480-vstup[pozice],pozice+1,ymax);
end;
 
procedure Vlozit(pozice:integer;vstup:Tpole;zbarveni:byte);
begin
  setcolor(zbarveni);
  line(pozice+1,480-vstup[pozice],pozice+1,ymax);
  setcolor(black);
  line(pozice+1,1,pozice+1,479-vstup[pozice]);
end;
 
procedure Vymenit(pozice1,pozice2:integer;vstup:Tpole;zbarveni:byte);
begin
  setcolor(zbarveni);
  line(pozice1+1,480-vstup[pozice2],pozice1+1,ymax);
  setcolor(black);
  line(pozice1+1,1,pozice1+1,479-vstup[pozice2]);
  setcolor(zbarveni);
  line(pozice2+1,480-vstup[pozice1],pozice2+1,ymax);
  setcolor(black);
  line(pozice2+1,1,pozice2+1,479-vstup[pozice1]);
end;
 
procedure InsertionSort(velikost:integer;nesetrideno:Tpole;cekat:integer);
var setrideno:Tpole;
    misto,index,prvek,posunuti:integer;
    barva:byte;
begin
  if ukol=true then barva:=15;
  setrideno:=nesetrideno;
  for misto:=2 to velikost do
    begin
      index:=1;
      while setrideno[misto]>setrideno[index] do index:=index+1;
      prvek:=setrideno[misto];
      if ukol=true then Vyjmout(misto,setrideno);
      for posunuti:=misto downto index+1 do
        begin
          if ukol=true then delay(cekat);
          setrideno[posunuti]:=setrideno[posunuti-1];
          if ukol=true then Vymenit(posunuti,posunuti-1,setrideno,barva);
        end;
      setrideno[index]:=prvek;
      if ukol=true then Vlozit(index,setrideno,barva);
    end;
end;
 
procedure BubbleSort(velikost:integer;nesetrideno:Tpole;cekat:integer);
var setrideno:Tpole;
    misto,index,prvek,skok:integer;
    barva:byte;
begin
  if ukol=true then barva:=9;
  setrideno:=nesetrideno;
  misto:=velikost;
  repeat
    begin
      skok:=misto-1;
      for index:=1 to misto-1 do
        begin
          if setrideno[index]>setrideno[index+1] then
            begin
              if ukol=true then delay(cekat);
              prvek:=setrideno[index];
              if ukol=true then Vymenit(index,index+1,setrideno,barva);
              setrideno[index]:=setrideno[index+1];
              setrideno[index+1]:=prvek;
              skok:=index;
            end;
        end;
      misto:=skok;
    end;
  until misto<=2;
end;
 
procedure ShakerSort(velikost:integer;nesetrideno:Tpole;cekat:integer);
var setrideno:Tpole;
    index,prvek,skok,dolni,horni:integer;
    barva:byte;
    smer:boolean;
begin
  if ukol=true then barva:=10;
  setrideno:=nesetrideno;
  horni:=velikost;
  dolni:=1;
  index:=0;
  smer:=true;
  skok:=horni;
  repeat
    begin
      repeat
        begin
          if smer=true then
            begin
              index:=index+1;
              if setrideno[index]>setrideno[index+1] then
                begin
                  if ukol=true then delay(cekat);
                  prvek:=setrideno[index];
                  if ukol=true then Vymenit(index,index+1,setrideno,barva);
                  setrideno[index]:=setrideno[index+1];
                  setrideno[index+1]:=prvek;
                  skok:=index;
                end
            end
          else
            begin
              index:=index-1;
              if setrideno[index+1]<setrideno[index] then
                begin
                  if ukol=true then delay(cekat);
                  prvek:=setrideno[index];
                  if ukol=true then Vymenit(index,index+1,setrideno,barva);
                  setrideno[index]:=setrideno[index+1];
                  setrideno[index+1]:=prvek;
                  skok:=index+1;
                end;
            end;
        end;
      until ((smer=true) and (index+1=horni)) or ((smer=false) and (index=dolni));
      if smer=true then
        begin
          smer:=false;
          horni:=skok;
          index:=skok;
        end
      else
        begin
          smer:=true;
          dolni:=skok;
          index:=skok-1;
        end;
    end;
  until horni<=dolni;
end;
 
procedure SelectionSort(velikost:integer;nesetrideno:Tpole;cekat:integer);
var setrideno:Tpole;
    misto1,misto2,index,prvek:integer;
    barva:byte;
begin
  if ukol=true then barva:=11;
  setrideno:=nesetrideno;
  for misto1:=velikost downto 2 do
    begin
      if ukol=true then delay(cekat);
      index:=1;
      for misto2:=1 to misto1 do
        begin
          if setrideno[misto2]>setrideno[index] then index:=misto2;
        end;
      prvek:=setrideno[index];
      if ukol=true then Vymenit(index,misto1,setrideno,barva);
      setrideno[index]:=setrideno[misto1];
      setrideno[misto1]:=prvek;
    end;
end;
 
procedure BublejHaldou(velikost,otec:integer;var halda:Tpole;barva,cekat:integer);
var syn,vymena:integer;
begin
  while 2*otec<=velikost do
    begin
      if ukol=true then delay(cekat);
      syn:=2*otec;
      if (syn<velikost) and (halda[syn]<halda[syn+1]) then syn:=syn+1;
      if halda[otec]>=halda[syn] then break;
      vymena:=halda[otec];
      if ukol=true then Vymenit(otec,syn,halda,barva);
      halda[otec]:=halda[syn];
      halda[syn]:=vymena;
      otec:=syn;
    end;
end;
 
procedure HeapSort(velikost:integer;nesetrideno:Tpole;cekat:integer);
var setrideno:Tpole;
    misto,prvek:integer;
    barva:byte;
begin
  if ukol=true then barva:=12;
  setrideno:=nesetrideno;
  for misto:=(velikost div 2) downto 1 do BublejHaldou(velikost,misto,setrideno,barva,cekat);
  for misto:=velikost downto 2 do
    begin
      if ukol=true then delay(cekat);
      prvek:=setrideno[1];
      if ukol=true then Vymenit(1,misto,setrideno,barva);
      setrideno[1]:=setrideno[misto];
      setrideno[misto]:=prvek;
      BublejHaldou(misto-1,1,setrideno,barva,cekat);
    end;
end;
 
procedure MergeSort(var setrideno,pomocne:Tpole;levy,pravy,cekat:integer);
var i,j,k,stred:integer;
    barva:byte;
begin
  if hradlo=true then
    begin
      for k:=levy to pravy do pomocne[k]:=setrideno[k];
    end;
  if ukol=true then barva:=13;
  stred:=(levy+pravy) div 2;
  if levy<pravy then MergeSort(setrideno,pomocne,levy,stred,cekat);
  if stred+1<pravy then MergeSort(setrideno,pomocne,stred+1,pravy,cekat);
  i:=levy;
  j:=stred+1;
  k:=levy;
  while (i<=stred) and (j<=pravy) do
    begin
      if setrideno[i]<=setrideno[j] then
        begin
          pomocne[k]:=setrideno[i];
          if ukol=true then delay(cekat);
          if ukol=true then Vymenit(k,i,pomocne,barva);
          i:=i+1;
        end
      else
        begin
          pomocne[k]:=setrideno[j];
          if ukol=true then delay(cekat);
          if ukol=true then Vymenit(k,j,pomocne,barva);
          j:=j+1;
        end;
      k:=k+1;
    end;
  while i<=stred do
    begin
      pomocne[k]:=setrideno[i];
      delay(cekat);
      if ukol=true then Vymenit(k,i,pomocne,barva);
      i:=i+1;
      k:=k+1;
    end;
  while j<=pravy do
    begin
      pomocne[k]:=setrideno[j];
      if ukol=true then delay(cekat);
      if ukol=true then Vymenit(k,j,pomocne,barva);
      j:=j+1;
      k:=k+1;
    end;
  for k:=levy to pravy do
    begin
      setrideno[k]:=pomocne[k];
      if ukol=true then delay(cekat);
      if ukol=true then Vyjmout(k,setrideno);
      if ukol=true then Vlozit(k,setrideno,barva);
    end;
end;
 
procedure QuickSort(var setrideno:Tpole;levy,pravy,cekat:integer);
var i,j,pivot,menic:integer;
    barva:byte;
begin
  if ukol=true then barva:=14;
  i:=levy;
  j:=pravy;
  pivot:=setrideno[(i+j) div 2];
  repeat
    begin
      while setrideno[i]<pivot do i:=i+1;
      while setrideno[j]>pivot do j:=j-1;
      if i<=j then
      begin
        if ukol=true then delay(cekat);
        menic:=setrideno[i];
        if ukol=true then Vymenit(i,j,setrideno,barva);
        setrideno[i]:=setrideno[j];
        setrideno[j]:=menic;
        i:=i+1;
        j:=j-1;
      end;
    end;
  until i>=j;
  if j>levy then QuickSort(setrideno,levy,j,cekat);
  if i<pravy then QuickSort(setrideno,i,pravy,cekat);
end;
 
procedure SetridPole(typ:byte);
var polecisel,pomocne:Tpole;
    x,prodleva:integer;
begin
  repeat
    begin
      writeln;
      write('Prodleva vykreslovani grafu (0 az 100 ms): ');
      readln(prodleva);
    end;
  until (prodleva>=0) and (prodleva<=100);
  GenerujPole(polecisel);
  detectgraph(graphdriver, graphmode);
  initgraph(graphdriver, graphmode, 'C:/TP/BP7/BGI');
  setcolor(7);
  line(1,1,1,480);
  line(1,480,640,480);
  case typ of
    1: setcolor(15);
    2: setcolor(9);
    3: setcolor(10);
    4: setcolor(11);
    5: setcolor(12);
    6: setcolor(13);
    7: setcolor(14)
  end;
  hradlo:=true;
  for x:=1 to xmax do line(x+1,480-polecisel[x],x+1,ymax);
  case typ of
    1: InsertionSort(xmax,polecisel,prodleva);
    2: BubbleSort(xmax,polecisel,prodleva);
    3: ShakerSort(xmax,polecisel,prodleva);
    4: SelectionSort(xmax,polecisel,prodleva);
    5: HeapSort(xmax,polecisel,prodleva);
    6: MergeSort(polecisel,pomocne,1,xmax,prodleva);
    7: QuickSort(polecisel,1,xmax,prodleva)
  end;
end;
 
procedure SpocitejGraf(opakovani:byte;seznam:Tmalepole);
var opakuj:byte;
    balon,pomocne:Tpole;
    s1,s2,v1,v2,m1,m2,h1,h2:word;
    cas1,cas2:longint;
    zaplneni,n:integer;
begin
  randomize;
  detectgraph(graphdriver, graphmode);
  initgraph(graphdriver, graphmode, 'C:/TP/BP7/BGI');
  setcolor(7);
  line(1,1,1,480);
  line(1,480,640,480);
  GenerujPole(balon);
  for opakuj:=1 to opakovani do
  begin
    zaplneni:=2;
    cas2:=0;
    n:=0;
    repeat
      begin
        gettime(h1,m1,v1,s1);
        case seznam[opakuj] of
          1: for n:=1 to 10000 do
               begin
                 InsertionSort(zaplneni,balon,0);
                 n:=n+1;
               end;
          2: for n:=1 to 10000 do
               begin
                 BubbleSort(zaplneni,balon,0);
                 n:=n+1;
               end;
          3: for n:=1 to 10000 do
               begin
                 ShakerSort(zaplneni,balon,0);
                 n:=n+1;
               end;
          4: for n:=1 to 10000 do
               begin
                 SelectionSort(zaplneni,balon,0);
                 n:=n+1;
               end;
          5: for n:=1 to 10000 do
               begin
                 HeapSort(zaplneni,balon,0);
                 n:=n+1;
               end;
          6: for n:=1 to 10000 do
               begin
                 MergeSort(balon,pomocne,1,zaplneni,0);
                 n:=n+1;
               end;
          7: for n:=1 to 10000 do
               begin
                 QuickSort(balon,1,zaplneni,0);
                 n:=n+1;
               end
        end;
        gettime(h2,m2,v2,s2);
        cas1:=cas2;
        cas2:=(h2*60*60*100+m2*60*100+v2*100+s2)-(h1*60*60*100+m1*60*100+v1*100+s1);
        case seznam[opakuj] of
          1: setcolor(15);
          2: setcolor(9);
          3: setcolor(10);
          4: setcolor(11);
          5: setcolor(12);
          6: setcolor(13);
          7: setcolor(14)
        end;
        line(4*zaplneni+1-4,479-(6*cas1),4*zaplneni+1,479-(6*cas2));
        zaplneni:=zaplneni+1;
      end;
    until zaplneni>=160;
  end;
end;
 
begin
  clrscr;
  writeln('SORTER - demonstrace trideni dat');
  writeln('Copyright (c) 2007 Petr Koupy');
  repeat
    begin
      writeln;
      writeln('Co chcete provest?');
      writeln('(1) Setridit vygenerovane pole');
      writeln('(2) Zobrazit graf casove slozitosti');
      write('Volba: ');
      readln(volba);
    end;
  until (volba=1) or (volba=2);
  if volba=1 then
    begin
      ukol:=true;
      writeln;
      writeln('Jaky tridici algoritmus chcete pouzit?');
      textcolor(15); writeln('(1) InsertionSort');
      textcolor(9); writeln('(2) BubbleSort');
      textcolor(10); writeln('(3) ShakerSort');
      textcolor(11); writeln('(4) SelectionSort');
      textcolor(12); writeln('(5) HeapSort');
      textcolor(13); writeln('(6) MergeSort');
      textcolor(14); writeln('(7) QuickSort');
      repeat
        begin
          textcolor(7); write('Volba: ');
          readln(volba);
        end;
      until (volba>=1) and (volba<=7);
      SetridPole(volba);
    end
  else
    begin
      ukol:=false;
      repeat
        begin
          writeln;
          writeln('Kolik algoritmu chcete propocitat (1 az 7)?');
          write('Pocet: ');
          readln(pocet);
        end;
      until (pocet>=1) and (pocet<=7);
      writeln;
      writeln('Jaky tridici algoritmus chcete zaradit do fronty?');
      textcolor(15); writeln('(1) InsertionSort');
      textcolor(9); writeln('(2) BubbleSort');
      textcolor(10); writeln('(3) ShakerSort');
      textcolor(11); writeln('(4) SelectionSort');
      textcolor(12); writeln('(5) HeapSort');
      textcolor(13); writeln('(6) MergeSort');
      textcolor(14); writeln('(7) QuickSort');
      textcolor(7);
      for k:=1 to pocet do
        begin
          repeat
            begin
              write('Volba ',k,'. mista fronty: ');
              readln(fronta[k]);
            end;
          until (fronta[k]>=1) and (fronta[k]<=7);
        end;
      SpocitejGraf(pocet,fronta);
    end;
 
  readln;
end.