Cod sursa(job #1636190)

Utilizator TirauStelianTirau Ioan Stelian TirauStelian Data 6 martie 2016 23:29:58
Problema Sortare prin comparare Scor 40
Compilator fpc Status done
Runda Arhiva educationala Marime 1.44 kb
program heapsort;
var f,g:text;
    bufin,bufout:array [1..1 shl 16] of char;
    v:array of longint;
    i,n,c,limita,nod,key:longint;
  procedure interschimbare(var a,b:longint);
  var aux:longint;
  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); setlength(v,n+1);
  for c:=1 to n do //construiesc minheapul
    begin
      read(f,v[c]);
      key:=v[c];
      nod:=c;
      while (nod div 2>0)and(key<v[nod div 2]) do
        begin
          v[nod]:=v[nod div 2];
          nod:=nod div 2;
        end;
      v[nod]:=key;
    end;
  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.