Cod sursa(job #42754)

Utilizator gurneySachelarie Bogdan gurney Data 29 martie 2007 14:55:44
Problema Order Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.8 kb
var a:array[1..120000] of word;
    n,m,i,j,k,p,q:longint;
    f1,f2:text;
procedure constr(i,st,dr:longint);
var k:longint;
begin
  if st=dr then
    a[i]:=1
  else
  begin
    k:=(st+dr)shr 1;
    a[i]:=dr-st+1;
    constr(2*i,st,k);
    constr(2*i+1,k+1,dr);
  end;
end;
function cat(poz,st,dr,x:word):word;
var mij:word;
begin
   mij:=(st+dr)div 2;
   if x=dr then cat:=a[poz] else
   begin
     if x>mij then cat:=a[poz*2]+cat(2*poz+1,mij+1,dr,x)
     else
     cat:=cat(2*poz,st,mij,x);
   end;
end;
function det(poz,x,st,dr:word):word;
var mij:word;
begin
   mij:=(st+dr)div 2;
   if st=dr then det:=dr else
     begin
       if a[2*poz]<x then det:=det(2*poz+1,x-a[2*poz],mij+1,dr)
         else det:=det(2*poz,x,st,mij)
     end;
end;
procedure actualizare(poz:word);
var k,st,dr,mij:word;
begin
  k:=1;
  st:=1;
  dr:=2*n;
  while st<dr do
    begin
      dec(a[k]);
      mij:=(st+dr) div 2;
      if poz>mij then
        begin
          st:=mij+1;
          k:=k*2+1;
        end
        else
        begin
          dr:=mij;
          k:=k*2;
        end;
    end;
  dec(a[k]);
end;
begin
  assign (f1,'order.in');
  assign (f2,'order.out');
  reset (f1);
  readln (f1,n);
  close (f1);
  constr(1,1,2*n);
  k:=1;
  rewrite (f2);
  for i:=1 to n do
    begin
      if k=1 then p:=i else
        if i mod (n-i+1)=0 then p:=cat(1,1,2*n,k-1)+(n-i+1) else
      p:=(i mod (n-i+1))+cat(1,1,2*n,k-1);
      q:=det(1,p,1,2*n);
      if q=n then
       begin
         q:=n;
         actualizare(n);
         actualizare(2*n);
         write (f2,n,' ');
       end
       else
        begin
          q:=q mod n;
          actualizare(q);
          actualizare(q+n);
          write (f2,q,' ');
        end;
       k:=q;
    end;
  close(f2);
end.