Cod sursa(job #1939686)

Utilizator elffikkVasile Ermicioi elffikk Data 25 martie 2017 22:24:21
Problema Sortare prin comparare Scor 40
Compilator fpc Status done
Runda Arhiva educationala Marime 1.73 kb
type vector = array of longint;

var f1, f2:text;
  i, n:longint;
  a:vector;
  
procedure append(var a:vector; x:longint);
begin
  SetLength(a, Length(a)+1);
  a[Length(a)-1] := x;
end;  

function pop(var a:vector):longint;
var x:longint;
begin
  x:=a[Length(a)-1];
  SetLength(a, Length(a)-1);
  pop:=x;
end;
  
procedure qs(var a:vector);
var x,y,z: vector;
   q, i, p:longint;
begin
  if length(a)>1
  then begin
    p:=a[length(a) div 2];
    while length(a)>0 do 
    begin
      q:=pop(a);
      if q<p then append(x, q)
      else if q=p then append(y, q)
      else append(z, q);
    end;
    qs(x);
    qs(z);    
    for i:=0 to length(x)-1 do append(a, x[i]);
    for i:=0 to length(y)-1 do append(a, y[i]);
    for i:=0 to length(z)-1 do append(a, z[i]);    
  end;  
end;

procedure reverse(var a:vector);
var x:vector;
begin
  while length(a)>0 do
    append(x, pop(a));
  a:=x;
end;

procedure merge_sort(var a:vector);
var x,y:vector;
begin
  if length(a) > 1 then 
  begin
    {split}
    while length(a)>0 do
    begin
      append(x, pop(a));
      if length(a)>0 then append(y, pop(a));
    end;
    merge_sort(x);
    merge_sort(y);
    {merge}  
    while (length(x)>0) or (length(y)>0) do
      if (length(y)=0) or (length(x)>0) and (x[length(x)-1] > y[length(y)-1]) 
      then append(a, pop(x))
      else append(a, pop(y));
    reverse(a);   
  end;
end;
  
begin
  {read}
  assign(f1, 'algsort.in');
  reset(f1);
  readln(f1, n);
  SetLength(a, n);
  for i:=0 to n-1 do
    read(f1, a[i]);
  close(f1);
  {sort}
  merge_sort(a);
  {write}
  assign(f2, 'algsort.out');
  rewrite(f2);
  for i:=0 to length(a)-1 do write(f2, a[i],' ');
  close(f2);
end.