Cod sursa(job #1636210)

Utilizator TirauStelianTirau Ioan Stelian TirauStelian Data 6 martie 2016 23:51:46
Problema Sortare prin comparare Scor 40
Compilator fpc Status done
Runda Arhiva educationala Marime 1.23 kb
program heapsort;
var f,g:text;
    bufin,bufout:array [1..1 shl 17] of char;
    v:array [1..500005] of int64;
    i,n,c,limita,nod,key:longint;
  procedure interschimbare(var a,b:int64);
  var aux:int64;
  begin
    aux:=a;
    a:=b;
    b:=aux;
  end;
  procedure sift(n,k:integer);
  var son:integer;
  begin
       repeat
            son:=0;
            if k*2<=n then
                  begin
                     son:=k*2;
                     if (k*2+1<=n) and (v[k*2+1]<v[k*2]) then
                          son:=k*2+1;
                     if v[son]>=v[k] then
                         son:=0;
                  end;
            if son>0 then
               begin
                  interschimbare(v[k],v[son]);
                  k:=son;
               end;
       until son=0;
  end;
begin
  assign(f,'algsort.in');reset(f);
  assign(g,'algsort.out');rewrite(g);
  settextbuf(f,bufin);settextbuf(g,bufout);
  readln(f,n);
  for i:=1 to n do
    read(f,v[i]);
  for c:=n div 2 downto 1 do
    sift(n,c);
  for i:=n downto 2 do
    begin
      interschimbare(v[i],v[1]);
      write(g,v[i],' ');
      nod:=1;limita:=i-1;
      sift(limita,nod);
    end;
  writeln(g,v[1]);
  close(f);
  close(g);
end.