Cod sursa(job #1637857)

Utilizator TirauStelianTirau Ioan Stelian TirauStelian Data 7 martie 2016 19:41:24
Problema Sortare prin comparare Scor 100
Compilator fpc Status done
Runda Arhiva educationala Marime 1.09 kb
program heapsort;
var v:array of longint;
    f,g:text;
    n,i,limita:longint;
    bufin,bufout:array [1..1 shl 16] of char;
  procedure interschimbare(var a,b:longint);
  var aux:longint;
  begin
    aux:=a;
    a:=b;
    b:=aux;
  end;
  procedure cerne(k,l:longint);
  var son:longint;
  begin
    repeat
      son:=0;
      if k*2<=l then
        begin
          son:=k*2;
          if (k*2+1<=l)and(v[k*2]>v[k*2+1]) then
            son:=k*2+1;
          if v[son]>=v[k] then
            son:=0;
        end;
      if son>0 then
        begin
          interschimbare(v[son],v[k]);
          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);setlength(v,n+1);
  for i:=1 to n do
    read(f,v[i]);
  limita:=n div 2;
  for i:=limita downto 1 do
    cerne(i,n);
  for i:=n downto 2 do
    begin
      interschimbare(v[i],v[1]);
      write(g,v[i],' ');
      cerne(1,i-1);
    end;
  writeln(g,v[1]);
  close(f);close(g);
end.