Cod sursa(job #14421)

Utilizator Programmer01Mierla Laurentiu Marian Programmer01 Data 8 februarie 2007 22:54:01
Problema Stramosi Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.4 kb
program p1;
type tablou=array[0..250001,0..20] of 0..250001;
     arr=array[1..250001] of 0..250001;
var mat:^tablou;
    a,b,c,v:^arr;
    n,m,i,j,p,q,x,y:0..250001;
    f,g:text;
procedure parc(vf:longint);
var k:0..250001;
begin
for k:=1 to n do
if a^[k]=vf then
begin
c^[k]:=c^[vf]+1;
v^[c^[k]]:=k;
p:=c^[k];
mat^[k,1]:=v^[p-1];
i:=1;
j:=1;
repeat
j:=j+1;
i:=b^[j];
mat^[k,j]:=v^[p-i];
until p-i<1;
mat^[k,0]:=i div 2;
parc(k);
end;
end;
begin
assign(f,'stramosi.in');
reset(f);
assign(g,'stramosi.out');
rewrite(g);
read(f,n,m);
new(a);
new(b);
new(c);
j:=1;
b^[1]:=1;
i:=1;
repeat
j:=j+1;
i:=i+(i xor (i-1)) and i;
b^[j]:=i;
until j=20;
new(mat);
x:=1;
for i:=1 to n do
begin
read(f,a^[i]);
if a^[i]=0 then
begin
mat^[0,x]:=i;
x:=x+1;
end;
end;
for y:=1 to x-1 do
begin
c^[mat^[0,y]]:=1;
v^[1]:=mat^[0,y];
parc(mat^[0,y]);
end;
for y:=1 to m do
begin
readln(f,q,p);
x:=0;
j:=0;
repeat
j:=j+1;
b^[j]:=p mod 2;
if b^[j]=1 then
begin
x:=x+1;
c^[x]:=1 shl (j-1);
mat^[0,x]:=j;
end;
p:=p div 2;
until p<=1;
if p=1 then
begin
j:=j+1;
b^[j]:=p;
x:=x+1;
c^[x]:=1 shl (j-1);
mat^[0,x]:=j;
end;
x:=x+1;
if mat^[q,0]=0 then q:=0
else
while x>1 do
begin
x:=x-1;
if mat^[q,0]<c^[x] then
begin
i:=x;
q:=0;
end
else q:=mat^[q,mat^[0,x]];
end;
writeln(g,q);
end;
dispose(mat);
dispose(a);
dispose(b);
dispose(c);
close(g);
close(f);
end.