Cod sursa(job #681468)

Utilizator iulia_n2007Tica Iulia iulia_n2007 Data 17 februarie 2012 09:18:11
Problema Sortare prin comparare Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 3.12 kb
var a:array[0..100] of integer;
    ok:boolean;
    f,g:text;
    t,i,n,aux,p:integer;
begin
assign(f,'algsort.in'); reset (f);
assign(g,'algsort.out'); rewrite (g);
readln (f,n);
a[0]:=-maxint;
for i:=1 to n do
 begin read (f,a[i]);
       if (a[i div 2]>a[i]) then begin aux:=a[i div 2];
                                       a[i div 2]:=a[i];
                                       a[i]:=aux;
                                       t:=i div 2;
                                       ok:=false;
                                       while (t<>1) and (ok=false) do
                                         begin if (a[t]>=a[t div 2]) then ok:=true;
                                               if (a[t]<a[t div 2]) then begin aux:=a[t div 2];
                                                                               a[t div 2]:=a[t];
                                                                               a[t]:=aux;
                                                                               t:=t div 2;
                                                                         end;
                                         end;
                                  end;
  end;

while n<>2 do
 begin aux:=a[1];
       a[1]:=a[n];
       a[n]:=aux;
       write (g,a[n],' ');
       a[n]:=0;
       n:=n-1;
       if (a[2]<a[1]) and (a[2]<=a[3]) then begin aux:=a[2];
                                                 a[2]:=a[1];
                                                 a[1]:=aux;
                                                 p:=2;
                                            end;
       if (a[3]<a[1]) and (a[2]>a[3]) then begin aux:=a[3];
                                                 a[3]:=a[1];
                                                 a[1]:=aux;
                                                 p:=3;
                                            end;

      if (p*2<=n) then for i:=p to n do
                          begin
                                       if (a[i div 2]>a[i]) then begin aux:=a[i div 2];
                                       a[i div 2]:=a[i];
                                       a[i]:=aux;
                                       t:=i div 2;
                                       ok:=false;
                                       while (t<>0) and (ok=false) do
                                         begin if (a[t]>=a[t div 2]) then ok:=true;
                                               if (a[t]<a[t div 2]) then begin aux:=a[t div 2];
                                                                               a[t div 2]:=a[t];
                                                                               a[t]:=aux;
                                                                               t:=t div 2;
                                                                         end;
                                         end;
                                  end;




                                   end;


  end;
if a[2]<a[3] then write (g,a[2],' ',a[3]);
if a[2]>a[3] then write (g,a[3],' ',a[2]);
close (f);
close (g);

end.