Cod sursa(job #136894)

Utilizator ravediscret rave Data 16 februarie 2008 13:12:34
Problema Mese Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.83 kb
type mu=set of byte;
var f,g:text;
    a:array[1..200,1..200]of 0..1;
    n,s,p:integer;
   c,v:array[1..200]of byte;
    l:array[1..200]of mu;

procedure cit;
var i,b,c:integer;
begin
     assign(f,'mese.in');
     reset(f);
     assign(g,'mese.out');
     rewrite(g);
     readln(f,n,s);
     for i:=1 to n do begin
         readln(f,b,c);
         if b<>0 then a[b,i]:=1;
         v[i]:=c;
     end
end;

procedure mdrum;
var i,j,k:integer;
begin
     for k:=1 to n do
         for j:=1 to n do
             for j:=1 to n do
                 if (a[i,j]=1) and(i<>k)and(j<>k) then a[i,j]:=a[i,k]*a[k,j]
end;

procedure prel;
var i,j,h,r,ss:integer;
    bo,boo:boolean;
begin
     p:=0;
     l[p]:=[];
     c[p]:=0;
     for i:=1 to n do begin
            bo:=false;
            for j:=1 to p do
                if i in l[j] then begin
                   bo:=true;
                   break
                end;
            boo:=false;
            if not bo then
               for h:=1 to n do
                   if a[h,i]=1 then
                      for r:=1 to p do
                          if(h in l[r])and(c[r]+v[i]<=s) then  begin
                               l[r]:=l[r]+[i];
                               c[r]:=c[r]+v[i];
                               boo:=true;
                               for ss:=1 to n do
                                   if (a[i,ss]=1)and(c[r]+v[ss]<=s) then begin
                                      l[r]:=l[r]+[ss];
                                      c[r]:=c[r]+v[ss];
                                   end;
                          end;
            if not boo then begin
               p:=p+1;
               l[p]:=[i];
               c[p]:=v[i]
            end;
     end;
end;

begin
     cit;
     mdrum;
     prel;
     writeln(g,p);
     close(g)
end.