Cod sursa(job #35137)

Utilizator andradaqAndrada Georgescu andradaq Data 21 martie 2007 20:51:12
Problema Critice Scor 40
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.13 kb
 var fi:text;
    f:array[1..1001,1..1001] of longint;
    a:array[1..1001,0..1001] of integer;
    c,ind:array[1..1001,1..1001] of integer;
    max,cap,ns,x1,n,i,m,j,k,eps,s,t,p,q,llant:integer;
    lant,viz,cq,sol,zzz:array[1..1001] of integer;

procedure citire;
begin
assign(fi,'critice.in'); reset(Fi);
readln(fi,n,m);
for k:=1 to m do
 begin
 readln(fi,i,j,cap);
 inc(a[i,0]); a[i,a[i,0]]:=j;
 inc(a[j,0]); a[j,a[j,0]]:=i;
 c[i,j]:=cap;
 c[j,i]:=cap;
 ind[i,j]:=k;
 ind[j,i]:=k;
 end;
close(Fi);
end;

function bf:boolean;
var i,vf:integer;
begin
fillchar(viz,sizeof(viz),0);
viz[s]:=-1;
cq[1]:=s; p:=1; q:=1;
while (q<=p)and(viz[t]=0) do
 begin
 vf:=cq[q];
 for i:=1 to n do
  if (c[vf,i]>0)and(viz[i]=0) and
   ( (f[vf,i]<c[vf,i]) or (f[i,vf]>0)) then
      begin
      inc(p);
      cq[p]:=i;
      viz[i]:=vf;
      if i=t then break;
      end;
 inc(q);
 end;
if viz[t]<>0 then
  begin
  bf:=true;
  eps:=maxint;
  llant:=0; i:=t;
  while i<>-1 do
   begin
if viz[i]<>-1 then   if (f[viz[i],i]>=0)and(c[viz[i],i]-f[viz[i],i]<eps) then
      eps:=c[viz[i],i]-f[viz[i],i]
      else if (f[i,viz[i]]>0)and(f[i,viz[i]]<eps) then eps:=f[i,viz[i]];
   inc(llant);
   lant[llant]:=i;
   i:=viz[i];
   end;
   end else bf:=false;
end;

procedure flux_max;
var i:integer;
begin
fillchar(f,sizeof(f),0);
while bf do
 begin
 for i:=llant downto 2 do
  if (f[lant[i],lant[i-1]]<=0) then
  begin
    inc(f[lant[i],lant[i-1]],eps);
    f[lant[i-1],lant[i]]:=-f[lant[i],lant[i-1]];
    end
   else
   begin
   dec(f[lant[i-1],lant[i]],eps);
   f[lant[i],lant[i-1]]:=-f[lant[i-1],lant[i]];
   end;
  inc(max,eps);
 end;
end;

procedure stop(x:integer);
var vf,i:integer;
begin
fillchar (zzz,sizeof(zzz),0);
zzz[x]:=1; p:=1; q:=1; cq[1]:=x;
while q<=p do
 begin
 vf:=cq[q];
 for i:=1 to a[vf,0] do
  if (zzz[a[vf,i]]=0)and(f[vf,a[vf,i]]>0)and(f[vf,a[vf,i]]<c[vf,a[vf,i]]) then
      begin
      inc(p);
      cq[p]:=a[vf,i];
      zzz[a[vf,i]]:=1;
      end;
  inc(q);
  end;
end;

procedure stop2(x:integer);
var  vf,i:integer;
begin
fillchar (viz,sizeof(viz),0);
viz[x]:=1; p:=1; q:=1; cq[1]:=x; ns:=0;
while q<=p do
 begin
 vf:=cq[q];
 for i:=1 to a[vf,0] do
  if (viz[a[vf,i]]=0)then
  begin
  if (f[a[vf,i],vf]>0)and(f[a[vf,i],vf]<c[a[vf,i],vf]) then
      begin
      inc(p);
      cq[p]:=a[vf,i];
      viz[a[vf,i]]:=1;
      end
      else
      if {(zzz[a[vf,i]]=1)and}(F[a[vf,i],vf]=c[a[vf,i],vf]) then
       begin
       inc(ns);
       sol[ns]:=ind[a[vf,i],vf];
       end
      end;
     inc(Q);
  end;
end;

procedure sort(l,r:integer);
var i,j,x,aux:integer;
begin
i:=l; j:=r; x:=sol[(i+j) div 2];
repeat
while sol[i]<x do inc(i);
while x<sol[j] do dec(j);
if i<=j then
  begin
  aux:=sol[i];sol[i]:=sol[j];sol[j]:=aux;
  i:=i+1; j:=j-1;
  end;
until i>j;
if l<j then sort(l,j);
if i<r then sort(i,r);
end;

procedure afis;
begin
assign(fi,'critice.out'); rewrite(Fi);
writeln(fi,ns);
for i:=1 to ns do  writeln(Fi,sol[i]);
close(fi);
end;

begin
citire;
max:=0;
s:=1; t:=n;
flux_max;
stop(1);
stop2(n);
sort(1,ns);
afis;
end.