Cod sursa(job #566268)

Utilizator andreifirstCioara Andrei Ioan andreifirst Data 28 martie 2011 20:24:28
Problema Sortare prin comparare Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 0.98 kb
var v:array [0..500001] of longint;
    aux, x:longint;
    i, j, n, k, an, min:longint;
    buf1, buf2:array [1..1 shl 17] of char;
    ok:boolean;
    f, g:text;

begin
assign (f, 'algsort.in');
reset (f);
settextbuf (f, buf1);
assign (g, 'algsort.out');
rewrite (g);
settextbuf (g, buf2);

read (f, n);
for i := 1 to n do
  begin
  read (f, v[i]);
  j:= i;
  while v[j]<v[j div 2] do
    begin
    aux:= v[j]; v[j]:=v[j div 2]; v[j div 2]:=aux;
    j:= j div 2;
    end;
  end;

an:=n;
for i := 1 to n do
  begin
  write (g, v[1], ' ');
  v[1]:= v[an];
  an:=an-1;
  j:=1;
  min:=1;
  while min <> 0 do
    begin
    min:=0;
    if j*2 <= an then
      begin
      min :=j*2;
      if (j*2+1<=an) then if (v[j*2+1]<v[j*2]) then min:=j*2+1;
      if v[min]<v[j] then min:=0;
      if min <> 0 then
        begin
        aux:=v[j]; v[j]:=v[min]; v[min]:=aux;
        j:=min;
        end;
      end;
    end;
  end;


close (f); close (g);
end.