Cod sursa(job #69612)

Utilizator MDanFMI - Dan Moldovan MDan Data 3 iulie 2007 17:24:53
Problema Stramosi Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.11 kb
type vec=array [1..13] of longint;
var f,g:text;
    ok,ok1:boolean;
    n,m,p,lk,lk2,cont,cont2,contor,egal,q,aux,aux2,aux3,auxaux,auxaux3,j,i:longint;
    a,b,c,d,e,asd:vec;
function stanga(i:integer):integer;
begin
stanga:=2*i;
end;
function dreapta(i:integer):integer;
begin
dreapta:=2*i+1;
end;
function parinte (i:integer):integer;
begin
parinte:=trunc(i/2);
end;
procedure reconstituieheap(i:integer);
var l,r,maxim:integer;
begin
l:=stanga(i);
r:=dreapta(i);
if (l<=aux2) and (a[l]>a[i])
then
    maxim:=l
else
    maxim:=i;
if (r<=aux2) and (a[r]>a[maxim])
then
    maxim:=r;
if maxim<>i
then
    begin
    aux:=a[i];
    a[i]:=a[maxim];
    a[maxim]:=aux;
    auxaux:=c[i];
    c[i]:=c[maxim];
    c[maxim]:=auxaux;
      auxaux:=asd[i];
    asd[i]:=asd[maxim];
    asd[maxim]:=auxaux;
    reconstituieheap(maxim);
    end;
end;
procedure construiesteheap;
begin
aux2:=j;
for i:=trunc(j/2) downto 1 do
reconstituieheap(i);
end;
procedure heapsort;
begin
construiesteheap;
for i:=j downto 2 do
    begin
    aux3:=a[1];
    a[1]:=a[i];
    a[i]:=aux3;
    auxaux3:=c[1];
    c[1]:=c[i];
    c[i]:=auxaux3;
    auxaux3:=asd[1];
    asd[1]:=asd[i];
    asd[i]:=auxaux3;
    aux2:=aux2-1;
    reconstituieheap(1);
    end;
end;
procedure reconstituieheap2(i:integer);
var l,r,maxim:integer;
begin
l:=stanga(i);
r:=dreapta(i);
if (l<=aux2) and (d[l]>d[i])
then
    maxim:=l
else
    maxim:=i;
if (r<=aux2) and (d[r]>d[maxim])
then
    maxim:=r;
if maxim<>i
then
    begin
    aux:=d[i];
    d[i]:=d[maxim];
    d[maxim]:=aux;
      auxaux:=asd[i];
    asd[i]:=asd[maxim];
    asd[maxim]:=auxaux;
    reconstituieheap2(maxim);
    end;
end;
procedure construiesteheap2;
begin
aux2:=j;
for i:=trunc(j/2) downto 1 do
reconstituieheap2(i);
end;
procedure heapsort2;
begin
construiesteheap2;
for i:=j downto 2 do
    begin
    aux3:=d[1];
    d[1]:=d[i];
    d[i]:=aux3;
    auxaux:=asd[i];
    asd[i]:=asd[i];
    asd[i]:=auxaux;
    aux2:=aux2-1;
    reconstituieheap2(1);
    end;
end;
procedure reconstituieheap3(i:integer);
var l,r,maxim:integer;
begin
l:=stanga(i);
r:=dreapta(i);
if (l<=aux2) and (asd[l]>asd[i])
then
    maxim:=l
else
    maxim:=i;
if (r<=aux2) and (asd[r]>asd[maxim])
then
    maxim:=r;
if maxim<>i
then
    begin
    aux:=asd[i];
    asd[i]:=asd[maxim];
    asd[maxim]:=aux;
    auxaux:=e[i];
    e[i]:=e[maxim];
    e[maxim]:=auxaux;
    reconstituieheap3(maxim);
    end;
end;
procedure construiesteheap3;
begin
aux2:=j;
for i:=trunc(j/2) downto 1 do
reconstituieheap3(i);
end;
procedure heapsort3;
begin
construiesteheap3;
for i:=j downto 2 do
    begin
    aux3:=asd[1];
    asd[1]:=asd[i];
    asd[i]:=aux3;
    auxaux:=e[1];
    e[1]:=e[i];
    e[i]:=auxaux;
    aux2:=aux2-1;
    reconstituieheap3(1);
    end;
end;
begin
assign (f,'stramosi.in');
assign (g,'stramosi.out');
reset (f);
rewrite (g);
read (f,n,m);
readln (f);
for i:=1 to n do
read (f,b[i]);
cont:=1;
for i:=1 to m do
begin
readln (f);
read (f,a[i],c[i]);
asd[i]:=i;
end;
j:=m;
heapsort;

lk:=0;
lk2:=1;
ok:=true;
while ok do
begin
lk:=lk+lk2;
egal:=a[lk];
lk2:=1;
d[lk2]:=c[lk];
ok1:=true;
          while ok1 do
          begin
          if egal=a[lk+1]
          then
              begin
              lk2:=lk2+1;
              lk:=lk+1;
              d[lk2]:=c[lk];
              end
          else
              begin
              ok1:=false;
              j:=lk2;
              heapsort2;
              cont2:=1;
                        while cont2<=lk2 do
                        begin
                             e[cont]:=b[a[cont]];
                             for contor:=2 to c[cont] do
                             begin
                             e[cont]:=b[e[cont]];
                             end;
                             cont:=cont+1;
                             cont2:=cont2+1;
                        end;
              end;
          end;
if lk>m
then
    ok:=false;
end;
j:=m;
heapsort3;

for i:=1 to m do
writeln (g,e[i]);

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